Released DG*5.3*635 SEQ #588 Extracted from mail message **KIDS**:DG*5.3*635^ **INSTALL NAME** DG*5.3*635 "BLD",6310,0) DG*5.3*635^REGISTRATION^0^3050920^y "BLD",6310,4,0) ^9.64PA^46^2 "BLD",6310,4,45,0) 45 "BLD",6310,4,45,2,0) ^9.641^45.06^1 "BLD",6310,4,45,2,45.06,0) CPT RECORD DATE/TIME (sub-file) "BLD",6310,4,45,2,45.06,1,0) ^9.6411^.05^7 "BLD",6310,4,45,2,45.06,1,.01,0) CPT RECORD DATE/TIME "BLD",6310,4,45,2,45.06,1,.02,0) REFERRING OR ORDERING PROVIDER "BLD",6310,4,45,2,45.06,1,.03,0) RENDERING PROVIDER "BLD",6310,4,45,2,45.06,1,.05,0) RENDERING LOCATION "BLD",6310,4,45,2,45.06,1,.06,0) VISIT NUMBER "BLD",6310,4,45,2,45.06,1,.07,0) DATA TO PCE FLAG "BLD",6310,4,45,2,45.06,1,.09,0) DELETE FLAG "BLD",6310,4,45,222) y^n^p^^^^n^^n "BLD",6310,4,45,224) "BLD",6310,4,46,0) 46 "BLD",6310,4,46,2,0) ^9.641^46^1 "BLD",6310,4,46,2,46,0) INPATIENT CPT CODE (File-top level) "BLD",6310,4,46,2,46,1,0) ^9.6411^.01^4 "BLD",6310,4,46,2,46,1,.01,0) CPT CODE "BLD",6310,4,46,2,46,1,.02,0) CPT MODIFIER 1 "BLD",6310,4,46,2,46,1,.03,0) CPT MODIFIER 2 "BLD",6310,4,46,2,46,1,.04,0) PRIMARY DIAGNOSIS "BLD",6310,4,46,222) y^n^p^^^^n^^n "BLD",6310,4,46,224) "BLD",6310,4,"APDD",45,45.06) "BLD",6310,4,"APDD",45,45.06,.01) "BLD",6310,4,"APDD",45,45.06,.02) "BLD",6310,4,"APDD",45,45.06,.03) "BLD",6310,4,"APDD",45,45.06,.05) "BLD",6310,4,"APDD",45,45.06,.06) "BLD",6310,4,"APDD",45,45.06,.07) "BLD",6310,4,"APDD",45,45.06,.09) "BLD",6310,4,"APDD",46,46) "BLD",6310,4,"APDD",46,46,.01) "BLD",6310,4,"APDD",46,46,.02) "BLD",6310,4,"APDD",46,46,.03) "BLD",6310,4,"APDD",46,46,.04) "BLD",6310,4,"B",45,45) "BLD",6310,4,"B",46,46) "BLD",6310,6) 39^ "BLD",6310,"INID") ^y "BLD",6310,"INIT") DGPTEMP "BLD",6310,"KRN",0) ^9.67PA^8989.52^19 "BLD",6310,"KRN",.4,0) .4 "BLD",6310,"KRN",.4,"NM",0) ^9.68A^2^2 "BLD",6310,"KRN",.4,"NM",1,0) 801notsenttopce FILE #45^45^0 "BLD",6310,"KRN",.4,"NM",2,0) 801HEADER FILE #45^45^0 "BLD",6310,"KRN",.4,"NM","B","801HEADER FILE #45",2) "BLD",6310,"KRN",.4,"NM","B","801notsenttopce FILE #45",1) "BLD",6310,"KRN",.401,0) .401 "BLD",6310,"KRN",.401,"NM",0) ^9.68A^1^1 "BLD",6310,"KRN",.401,"NM",1,0) 801FIND FILE #45^45^0 "BLD",6310,"KRN",.401,"NM","B","801FIND FILE #45",1) "BLD",6310,"KRN",.402,0) .402 "BLD",6310,"KRN",.402,"NM",0) ^9.68A^^ "BLD",6310,"KRN",.403,0) .403 "BLD",6310,"KRN",.403,"NM",0) ^9.68A^^ "BLD",6310,"KRN",.5,0) .5 "BLD",6310,"KRN",.84,0) .84 "BLD",6310,"KRN",3.6,0) 3.6 "BLD",6310,"KRN",3.8,0) 3.8 "BLD",6310,"KRN",3.8,"NM",0) ^9.68A^1^1 "BLD",6310,"KRN",3.8,"NM",1,0) DG PTF 801 TO PCE ERROR^^0 "BLD",6310,"KRN",3.8,"NM","B","DG PTF 801 TO PCE ERROR",1) "BLD",6310,"KRN",9.2,0) 9.2 "BLD",6310,"KRN",9.8,0) 9.8 "BLD",6310,"KRN",9.8,"NM",0) ^9.68A^17^15 "BLD",6310,"KRN",9.8,"NM",1,0) DGAPI1^^0^B23313301 "BLD",6310,"KRN",9.8,"NM",2,0) DGPTFM^^0^B43402022 "BLD",6310,"KRN",9.8,"NM",3,0) DGPTFM2^^0^B46843310 "BLD",6310,"KRN",9.8,"NM",4,0) DGPTFM21^^0^B15573212 "BLD",6310,"KRN",9.8,"NM",5,0) DGPTFREL^^0^B9388045 "BLD",6310,"KRN",9.8,"NM",6,0) DGPTUTL1^^0^B29888402 "BLD",6310,"KRN",9.8,"NM",7,0) DGPTFM3^^0^B16699199 "BLD",6310,"KRN",9.8,"NM",8,0) DGPTFQWK^^0^B17529486 "BLD",6310,"KRN",9.8,"NM",9,0) DGPTOPCE^^0^B1042901 "BLD",6310,"KRN",9.8,"NM",10,0) DGPTEMP^^0^B1191570 "BLD",6310,"KRN",9.8,"NM",13,0) DGPTFJ^^0^B7406575 "BLD",6310,"KRN",9.8,"NM",14,0) DGPTFJC^^0^B46752372 "BLD",6310,"KRN",9.8,"NM",15,0) DGPTFM1^^0^B19186087 "BLD",6310,"KRN",9.8,"NM",16,0) DGPTFM1A^^0^B6978809 "BLD",6310,"KRN",9.8,"NM",17,0) DGPTF41^^0^B9939139 "BLD",6310,"KRN",9.8,"NM","B","DGAPI1",1) "BLD",6310,"KRN",9.8,"NM","B","DGPTEMP",10) "BLD",6310,"KRN",9.8,"NM","B","DGPTF41",17) "BLD",6310,"KRN",9.8,"NM","B","DGPTFJ",13) "BLD",6310,"KRN",9.8,"NM","B","DGPTFJC",14) "BLD",6310,"KRN",9.8,"NM","B","DGPTFM",2) "BLD",6310,"KRN",9.8,"NM","B","DGPTFM1",15) "BLD",6310,"KRN",9.8,"NM","B","DGPTFM1A",16) "BLD",6310,"KRN",9.8,"NM","B","DGPTFM2",3) "BLD",6310,"KRN",9.8,"NM","B","DGPTFM21",4) "BLD",6310,"KRN",9.8,"NM","B","DGPTFM3",7) "BLD",6310,"KRN",9.8,"NM","B","DGPTFQWK",8) "BLD",6310,"KRN",9.8,"NM","B","DGPTFREL",5) "BLD",6310,"KRN",9.8,"NM","B","DGPTOPCE",9) "BLD",6310,"KRN",9.8,"NM","B","DGPTUTL1",6) "BLD",6310,"KRN",19,0) 19 "BLD",6310,"KRN",19,"NM",0) ^9.68A^2^2 "BLD",6310,"KRN",19,"NM",1,0) DG PRO FEE NOT SENT TO PCE^^0 "BLD",6310,"KRN",19,"NM",2,0) DG PTF OUTPUT MENU^^2 "BLD",6310,"KRN",19,"NM","B","DG PRO FEE NOT SENT TO PCE",1) "BLD",6310,"KRN",19,"NM","B","DG PTF OUTPUT MENU",2) "BLD",6310,"KRN",19.1,0) 19.1 "BLD",6310,"KRN",19.1,"NM",0) ^9.68A^^ "BLD",6310,"KRN",101,0) 101 "BLD",6310,"KRN",409.61,0) 409.61 "BLD",6310,"KRN",771,0) 771 "BLD",6310,"KRN",771,"NM",0) ^9.68A^^ "BLD",6310,"KRN",870,0) 870 "BLD",6310,"KRN",870,"NM",0) ^9.68A^^ "BLD",6310,"KRN",8989.51,0) 8989.51 "BLD",6310,"KRN",8989.52,0) 8989.52 "BLD",6310,"KRN",8994,0) 8994 "BLD",6310,"KRN","B",.4,.4) "BLD",6310,"KRN","B",.401,.401) "BLD",6310,"KRN","B",.402,.402) "BLD",6310,"KRN","B",.403,.403) "BLD",6310,"KRN","B",.5,.5) "BLD",6310,"KRN","B",.84,.84) "BLD",6310,"KRN","B",3.6,3.6) "BLD",6310,"KRN","B",3.8,3.8) "BLD",6310,"KRN","B",9.2,9.2) "BLD",6310,"KRN","B",9.8,9.8) "BLD",6310,"KRN","B",19,19) "BLD",6310,"KRN","B",19.1,19.1) "BLD",6310,"KRN","B",101,101) "BLD",6310,"KRN","B",409.61,409.61) "BLD",6310,"KRN","B",771,771) "BLD",6310,"KRN","B",870,870) "BLD",6310,"KRN","B",8989.51,8989.51) "BLD",6310,"KRN","B",8989.52,8989.52) "BLD",6310,"KRN","B",8994,8994) "BLD",6310,"QUES",0) ^9.62^^ "BLD",6310,"REQB",0) ^9.611^4^4 "BLD",6310,"REQB",1,0) DG*5.3*606^2 "BLD",6310,"REQB",2,0) DG*5.3*636^2 "BLD",6310,"REQB",3,0) SD*5.3*387^2 "BLD",6310,"REQB",4,0) DG*5.3*617^2 "BLD",6310,"REQB","B","DG*5.3*606",1) "BLD",6310,"REQB","B","DG*5.3*617",4) "BLD",6310,"REQB","B","DG*5.3*636",2) "BLD",6310,"REQB","B","SD*5.3*387",3) "FIA",45) PTF "FIA",45,0) ^DGPT( "FIA",45,0,0) 45IP "FIA",45,0,1) y^n^p^^^^n^^n "FIA",45,0,10) "FIA",45,0,11) "FIA",45,0,"RLRO") "FIA",45,0,"VR") 5.3^DG "FIA",45,45) 1 "FIA",45,45,30) "FIA",45,45.06) 1 "FIA",45,45.06,.01) "FIA",45,45.06,.02) "FIA",45,45.06,.03) "FIA",45,45.06,.05) "FIA",45,45.06,.06) "FIA",45,45.06,.07) "FIA",45,45.06,.09) "FIA",46) INPATIENT CPT CODE "FIA",46,0) ^DGCPT(46, "FIA",46,0,0) 46P "FIA",46,0,1) y^n^p^^^^n^^n "FIA",46,0,10) "FIA",46,0,11) "FIA",46,0,"RLRO") "FIA",46,0,"VR") 5.3^DG "FIA",46,46) 1 "FIA",46,46,.01) "FIA",46,46,.02) "FIA",46,46,.03) "FIA",46,46,.04) "INIT") DGPTEMP "IX",45,45,"AB",0) 45^AB^Used to print 801 transactions not sent to PCE^MU^^R^IR^W^45.06^^^^^S "IX",45,45,"AB",1) S ^DGPT("AB",X2(1),DA(1),DA)="" "IX",45,45,"AB",1.4) S X='X2(2)&'X2(3)&X2(1) "IX",45,45,"AB",2) K:X1(1)'="" ^DGPT("AB",X1(1),DA(1),DA) "IX",45,45,"AB",2.4) S X=X2(2)!X2(3)!(X(1)'=X(2)) "IX",45,45,"AB",11.1,0) ^.114IA^3^3 "IX",45,45,"AB",11.1,1,0) 1^F^45.06^.01^7^^F "IX",45,45,"AB",11.1,2,0) 2^F^45.06^.07^1^^F "IX",45,45,"AB",11.1,3,0) 3^F^45.06^.09^1^^F "KRN",.4,2752,-1) 0^1 "KRN",.4,2752,0) 801notsenttopce^3050328.1458^@^45^^@^3050408 "KRN",.4,2752,"DXS",1,9) S I(0,0)=$G(D0),DIP(1)=$S($D(^DGPT(D0,0)):^(0),1:""),D0=$P(DIP(1),U,1) S:'D0!'$D(^DPT(+D0,0)) D0=-1 S DIP(101)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(DIP(101),U,9) S D0=I(0,0) "KRN",.4,2752,"F",2) .01;C5~X DXS(1,9) W X K DIP;Z;"PATIENT:SOCIAL SECURITY NUMBER"~ "KRN",.4,2752,"H") Pro Fee Coding Not Sent to PCE "KRN",.4,2753,-1) 0^2 "KRN",.4,2753,0) 801HEADER^3050329.1008^@^45^^@^3050408 "KRN",.4,2753,"F",1) "Pro Fee Not Sent To PCE"~S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) S Y=X D DT K DIP;C50;R20;Z;"NOW";d~"PAGE"~ "KRN",.4,2753,"F",2) S X=$S($D(DC)#2:DC,1:"") W X K DIP;R2;Z;"PAGE"~W DGST;C25;Z;"W DGST"~" -"~W DGEND;L20;Z;"W DGEND"~"PATIENT";S1;C5~"SSN";C37~ "KRN",.4,2753,"F",3) S X="-",DIP(1)=$G(X) S X=80,X1=DIP(1) S %=X,X="" Q:X1="" S $P(X,X1,%\$L(X1)+1)=X1,X=$E(X,1,%) W X K DIP;C1;Z;"DUP("-",80)"~ "KRN",.4,2753,"H") PTF LIST "KRN",.401,2074,-1) 0^1 "KRN",.401,2074,0) 801FIND^3050328.1501^@^45^^@^3050408 "KRN",.401,2074,"%D",0) ^.4012^1^1^3050818^^^^ "KRN",.401,2074,"%D",1,0) Pro Fee Coding Not Sent to PCE "KRN",.401,2074,"BY0") DGPT("AB",^2 "KRN",.401,2074,"BY0D",0) ^.4011624^1^1 "KRN",.401,2074,"BY0D",1,0) 1^3000101^3041228 "KRN",.401,2074,"BY0D",1,1) ^;"CPT RECORD DATE/TIME: ";S2;C1 "KRN",.401,2074,"BY0D",1,2) X ^DD("DD") "KRN",3.8,6182,-1) 0^1 "KRN",3.8,6182,0) DG PTF 801 TO PCE ERROR^PU^n^^^0^ "KRN",3.8,6182,2,0) ^^2^2^3050913^ "KRN",3.8,6182,2,1,0) This mail group is for receiving of PTF 801 screen data to PCE filing "KRN",3.8,6182,2,2,0) error messages. "KRN",3.8,6182,3) "KRN",19,200,-1) 2^2 "KRN",19,200,0) DG PTF OUTPUT MENU^PTF Output Menu^^M^.5^^^^^^^5 "KRN",19,200,10,0) ^19.01IP^17^17 "KRN",19,200,10,17,0) 12760 "KRN",19,200,10,17,"^") DG PRO FEE NOT SENT TO PCE "KRN",19,200,"U") PTF OUTPUT MENU "KRN",19,12760,-1) 0^1 "KRN",19,12760,0) DG PRO FEE NOT SENT TO PCE^Pro Fee Coding Not Sent to PCE^^R^^^^^^^^PTF/DRG "KRN",19,12760,1,0) ^^1^1^3050325^ "KRN",19,12760,1,1,0) This option will list all the 801 screens which have not been sent to PCE. "KRN",19,12760,25) DGPTOPCE "KRN",19,12760,60) "KRN",19,12760,62) "KRN",19,12760,63) "KRN",19,12760,64) "KRN",19,12760,"U") PRO FEE CODING NOT SENT TO PCE "MBREQ") 0 "ORD",5,.4) .4;5;;;EDEOUT^DIFROMSO(.4,DA,"",XPDA);FPRE^DIFROMSI(.4,"",XPDA);EPRE^DIFROMSI(.4,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.4,DA,"",XPDA);DEL^DIFROMSK(.4,"",%) "ORD",5,.4,0) PRINT TEMPLATE "ORD",6,.401) .401;6;;;EDEOUT^DIFROMSO(.401,DA,"",XPDA);FPRE^DIFROMSI(.401,"",XPDA);EPRE^DIFROMSI(.401,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.401,DA,"",XPDA);DEL^DIFROMSK(.401,"",%) "ORD",6,.401,0) SORT TEMPLATE "ORD",11,3.8) 3.8;11;;;MAILG^XPDTA1;MAILGF1^XPDIA1;MAILGE1^XPDIA1;MAILGF2^XPDIA1;;MAILGDEL^XPDIA1(%) "ORD",11,3.8,0) MAIL GROUP "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,20,0) ^9.402P^^ "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 635^3050920^123457111 "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 15 "RTN","DGAPI1") 0^1^B23313301 "RTN","DGAPI1",1,0) DGAPI1 ;ALB/DWS - DG API TO COMUNICATE WITH PCE ;6/16/05 1:44pm "RTN","DGAPI1",2,0) ;;5.3;Registration;**635**;Aug 13, 1993 "RTN","DGAPI1",3,0) DATA2PCE(DFN,PTF,DGZP) ;SEND CPT PROCEDURE TRANSACTIONS TO PCE "RTN","DGAPI1",4,0) ; "RTN","DGAPI1",5,0) N DGVISIT,DR,DIE,DA,X,Y "RTN","DGAPI1",6,0) ; "RTN","DGAPI1",7,0) D BUILD "RTN","DGAPI1",8,0) ; "RTN","DGAPI1",9,0) I $P($G(DGZPRF(DGZP)),U,6) S DGVISIT=$P(DGZPRF(DGZP),U,6) "RTN","DGAPI1",10,0) ; "RTN","DGAPI1",11,0) S RES=$$DATA2PCE^PXAPI("^TMP(""DGPCE1"",$J,""PXAPI"")",107,"801 SCREEN",.DGVISIT) "RTN","DGAPI1",12,0) ; "RTN","DGAPI1",13,0) D:$D(^TMP("DGPCE1",$J,"PXAPI","DIERR")) ERR "RTN","DGAPI1",14,0) ; "RTN","DGAPI1",15,0) K ^TMP("DGPCE1",$J,"PXAPI") "RTN","DGAPI1",16,0) ; "RTN","DGAPI1",17,0) ; "RTN","DGAPI1",18,0) Q:RES<-1 RES "RTN","DGAPI1",19,0) ; "RTN","DGAPI1",20,0) S DR=".06////"_DGVISIT_";.07////1",DIE="^DGPT("_PTF_",""C"",",DA=DGZPRF(DGZP,0),DA(1)=PTF D ^DIE "RTN","DGAPI1",21,0) ; "RTN","DGAPI1",22,0) Q RES "RTN","DGAPI1",23,0) ; "RTN","DGAPI1",24,0) ERR ; looks to see if there is an trully an error "RTN","DGAPI1",25,0) N DGX,DGQ "RTN","DGAPI1",26,0) S (DGQ,DGX)=0 F S DGX=$O(^TMP("DGPCE1",$J,"PXAPI","DIERR",$J,DGX)) Q:'DGX!(DGQ) I $E($G(^TMP("DGPCE1",$J,"PXAPI","DIERR",$J,DGX,"TEXT",1)),1,5)="ERROR" S DGQ=1 D ERRMSG(DGX) "RTN","DGAPI1",27,0) Q "RTN","DGAPI1",28,0) ; "RTN","DGAPI1",29,0) ERRMSG(DGX) ; sends the error message "RTN","DGAPI1",30,0) N XMDUZ,XMSUB,XMTEXT,XMY,XMZ,XMMG,DGL,DGTXT,DGY "RTN","DGAPI1",31,0) ; "RTN","DGAPI1",32,0) D DEM^VADPT "RTN","DGAPI1",33,0) ; "RTN","DGAPI1",34,0) S XMDUZ="PTF MODULE",XMSUB="801 to PCE filing error" "RTN","DGAPI1",35,0) S XMY("G.DG PTF 801 TO PCE ERROR")="",XMY(DUZ)="",XMTEXT="DGTXT(" "RTN","DGAPI1",36,0) ; "RTN","DGAPI1",37,0) S DGTXT(1,0)="An error has occured while sending PTF 801 data to PCE." "RTN","DGAPI1",38,0) S DGTXT(2,0)=" " "RTN","DGAPI1",39,0) S DGTXT(3,0)=" Patient Name: "_VADM(1) "RTN","DGAPI1",40,0) S DGTXT(4,0)=" Social Security: "_$P(VADM(2),"^",2) "RTN","DGAPI1",41,0) S DGTXT(5,0)=" Date/Time: "_$$FMTE^XLFDT(+DGZPRF(DGZP)) "RTN","DGAPI1",42,0) S DGTXT(6,0)=" Location: "_$P($G(^SC($P(DGZPRF(DGZP),"^",5),0)),"^") "RTN","DGAPI1",43,0) S DGTXT(7,0)=" " "RTN","DGAPI1",44,0) ; "RTN","DGAPI1",45,0) S DGL=7,DGY=0 F S DGY=$O(^TMP("DGPCE1",$J,"PXAPI","DIERR",$J,DGX,"TEXT",DGY)) Q:'DGY!($E(^TMP("DGPCE1",$J,"PXAPI","DIERR",$J,DGX,"TEXT",DGY),1,25)="^TMP(""DGPCE1"",$J,""PXAPI"")") D "RTN","DGAPI1",46,0) . S DGL=DGL+1,DGTXT(DGL,0)=" "_^TMP("DGPCE1",$J,"PXAPI","DIERR",$J,DGX,"TEXT",DGY) "RTN","DGAPI1",47,0) ; "RTN","DGAPI1",48,0) D ^XMD "RTN","DGAPI1",49,0) D KVAR^VADPT "RTN","DGAPI1",50,0) ; "RTN","DGAPI1",51,0) Q "RTN","DGAPI1",52,0) ; "RTN","DGAPI1",53,0) DELVFILE(DFN,PTF,DGZP) ;DELETE VISIT IN PCE WHEN A CHANGE IS MADE "RTN","DGAPI1",54,0) N DIE,DA,DR S RES=1 "RTN","DGAPI1",55,0) S:$P(DGZPRF(DGZP),U,7) RES=$$DELVFILE^PXAPI("ALL",$P(DGZPRF(DGZP),U,6)) "RTN","DGAPI1",56,0) S DA=DGZPRF(DGZP,0),DA(1)=PTF "RTN","DGAPI1",57,0) S DIE="^DGPT("_PTF_",""C"",",DR=".06///@;.07////0" D ^DIE "RTN","DGAPI1",58,0) Q RES "RTN","DGAPI1",59,0) ; "RTN","DGAPI1",60,0) BUILD ; now build array for passing data to PCE "RTN","DGAPI1",61,0) N DGAPI,DGC,DGPROC,DGPROCZ,DGP,DGDXNO,DGDXC,DGDX,DGX "RTN","DGAPI1",62,0) K ^TMP("DGPCE1",$J,"PXAPI") S DGDXC=0 "RTN","DGAPI1",63,0) S DGAPI=$NA(^TMP("DGPCE1",$J,"PXAPI")) "RTN","DGAPI1",64,0) ; ---------encounter date/time---------------- "RTN","DGAPI1",65,0) S @DGAPI@("ENCOUNTER",1,"ENC D/T")=+DGZPRF(DGZP) "RTN","DGAPI1",66,0) ; --------------patient----------------------- "RTN","DGAPI1",67,0) S @DGAPI@("ENCOUNTER",1,"PATIENT")=DFN "RTN","DGAPI1",68,0) ; ---------------location--------------------- "RTN","DGAPI1",69,0) S @DGAPI@("ENCOUNTER",1,"HOS LOC")=$P(DGZPRF(DGZP),"^",5) "RTN","DGAPI1",70,0) ; --------------service category-------------- "RTN","DGAPI1",71,0) S @DGAPI@("ENCOUNTER",1,"SERVICE CATEGORY")="I" "RTN","DGAPI1",72,0) ; ---------------encounter type--------------- "RTN","DGAPI1",73,0) S @DGAPI@("ENCOUNTER",1,"ENCOUNTER TYPE")="P" "RTN","DGAPI1",74,0) ; ------------primary provider---------------- "RTN","DGAPI1",75,0) S @DGAPI@("PROVIDER",1,"NAME")=$P(DGZPRF(DGZP),"^",3) "RTN","DGAPI1",76,0) S @DGAPI@("PROVIDER",1,"PRIMARY")=1 "RTN","DGAPI1",77,0) ; ------------secondary provider------------- "RTN","DGAPI1",78,0) I $P(DGZPRF(DGZP),"^",2),$P(DGZPRF(DGZP),"^",2)'=$P(DGZPRF(DGZP),"^",3) S @DGAPI@("PROVIDER",2,"NAME")=$P(DGZPRF(DGZP),"^",2) "RTN","DGAPI1",79,0) ; ----------------procedures----------------- "RTN","DGAPI1",80,0) S DGC=0,DGPROC=0 F S DGPROC=$O(DGZPRF(DGZP,DGPROC)) Q:'DGPROC D "RTN","DGAPI1",81,0) . S DGPROCZ=$G(DGZPRF(DGZP,DGPROC)) Q:'DGPROCZ "RTN","DGAPI1",82,0) . S DGC=DGC+1,@DGAPI@("PROCEDURE",DGC,"PROCEDURE")=+DGPROCZ "RTN","DGAPI1",83,0) . ; --------------modifiers------------------ "RTN","DGAPI1",84,0) . F DGP=2,3 I $P(DGPROCZ,"^",DGP) S @DGAPI@("PROCEDURE",DGC,"MODIFIERS",$P($$MOD^ICPTMOD($P(DGPROCZ,"^",DGP),"I",+DGZPRF(DGZP)),"^",2))="" "RTN","DGAPI1",85,0) . ; --------------quantity------------------- "RTN","DGAPI1",86,0) . S @DGAPI@("PROCEDURE",DGC,"QTY")=$P(DGPROCZ,"^",14) "RTN","DGAPI1",87,0) . ; --------------diagnosis------------------ "RTN","DGAPI1",88,0) . F DGP=4:1:7,15:1:18 I $P(DGPROCZ,"^",DGP) D "RTN","DGAPI1",89,0) . . S DGDXNO=$S(DGP=4:"",DGP<15:DGP-3,1:DGP-11) "RTN","DGAPI1",90,0) . . S @DGAPI@("PROCEDURE",DGC,"DIAGNOSIS"_$S(DGDXNO<2:"",1:" "_DGDXNO))=$P(DGPROCZ,"^",DGP) "RTN","DGAPI1",91,0) . . I $D(DGDX($P(DGPROCZ,"^",DGP))) Q "RTN","DGAPI1",92,0) . . S DGDX($P(DGPROCZ,"^",DGP))="",DGDXC=DGDXC+1 "RTN","DGAPI1",93,0) . . S @DGAPI@("DX/PL",DGDXC,"DIAGNOSIS")=$P(DGPROCZ,"^",DGP) "RTN","DGAPI1",94,0) . . S:DGDXC=1 @DGAPI@("DX/PL",DGDXC,"PRIMARY")=1 "RTN","DGAPI1",95,0) . . S (DGY,DGX)=0 F S DGX=$O(^DGICD9(46.1,"C",PTF,DGX)) Q:'DGX!(DGY) I +$G(^DGICD9(46.1,DGX,0))=$P(DGPROCZ,"^",DGP) S DGY=DGX "RTN","DGAPI1",96,0) . . S DGY=$G(^DGICD9(46.1,+DGY,0)) "RTN","DGAPI1",97,0) . . I $L($P(DGY,"^",2)) S @DGAPI@("DX/PL",DGDXC,"PL SC")=$P(DGY,"^",2) "RTN","DGAPI1",98,0) . . I $L($P(DGY,"^",3)) S @DGAPI@("DX/PL",DGDXC,"PL AO")=$P(DGY,"^",3) "RTN","DGAPI1",99,0) . . I $L($P(DGY,"^",4)) S @DGAPI@("DX/PL",DGDXC,"PL IR")=$P(DGY,"^",4) "RTN","DGAPI1",100,0) . . I $L($P(DGY,"^",5)) S @DGAPI@("DX/PL",DGDXC,"PL EC")=$P(DGY,"^",5) "RTN","DGAPI1",101,0) . . I $L($P(DGY,"^",6)) S @DGAPI@("DX/PL",DGDXC,"PL MST")=$P(DGY,"^",6) "RTN","DGAPI1",102,0) . . I $L($P(DGY,"^",7)) S @DGAPI@("DX/PL",DGDXC,"PL HNC")=$P(DGY,"^",7) "RTN","DGAPI1",103,0) . . I $L($P(DGY,"^",8)) S @DGAPI@("DX/PL",DGDXC,"PL CV")=$P(DGY,"^",8) "RTN","DGAPI1",104,0) ; "RTN","DGAPI1",105,0) Q "RTN","DGAPI1",106,0) ; "RTN","DGPTEMP") 0^10^B1191570 "RTN","DGPTEMP",1,0) DGPTEMP ;ALB/DWS - TEMPORARY ROUTINE TO SET DELETE FLAGS IN 45.06 ;3/31/05 2:54pm "RTN","DGPTEMP",2,0) ;;5.3;Registration;**635**; Aug 13, 1993 "RTN","DGPTEMP",3,0) K ^DGPT("AB") "RTN","DGPTEMP",4,0) S DA(1)=0,DIK(1)=".01^AB" "RTN","DGPTEMP",5,0) F S DA(1)=$O(^DGPT(DA(1))) Q:DA(1)'=+DA(1) D "RTN","DGPTEMP",6,0) .S DIK="^DGPT("_DA(1)_",""C""," D ENALL^DIK "RTN","DGPTEMP",7,0) S XPDIDTOT=$P(^DGPT(0),U,4),COUNT=0 "RTN","DGPTEMP",8,0) S PTF=0 F S PTF=$O(^DGPT(PTF)) Q:'PTF D K BOOL "RTN","DGPTEMP",9,0) .S DGCPT=0 F S DGCPT=$O(^DGCPT(46,"C",PTF,DGCPT)) Q:'DGCPT D "RTN","DGPTEMP",10,0) ..S DATE=+^DGCPT(46,DGCPT,1) "RTN","DGPTEMP",11,0) ..S:'$G(BOOL(DATE)) BOOL(DATE)='$G(^DGCPT(46,DGCPT,9)) "RTN","DGPTEMP",12,0) .S DA=0 F S DA=$O(^DGPT(PTF,"C",DA)) Q:'DA D "RTN","DGPTEMP",13,0) ..S DATE=+^DGPT(PTF,"C",DA,0) Q:$G(BOOL(DATE)) "RTN","DGPTEMP",14,0) ..S DR=".09////1",DIE="^DGPT("_PTF_",""C"",",DA(1)=PTF D ^DIE "RTN","DGPTEMP",15,0) .S COUNT=COUNT+1 I COUNT#1000=0 D UPDATE^XPDID(COUNT) "RTN","DGPTEMP",16,0) Q "RTN","DGPTF41") 0^17^B9939139 "RTN","DGPTF41",1,0) DGPTF41 ;ALB/JDS - PTF ENTRY/EDIT-4 ;4/26/05 1:22pm "RTN","DGPTF41",2,0) ;;5.3;Registration;**64,635**;Aug 13, 1993 "RTN","DGPTF41",3,0) ; "RTN","DGPTF41",4,0) ACT ; -- 701 actions "RTN","DGPTF41",5,0) G ACT1:DGST "RTN","DGPTF41",6,0) S DGCFL=0 I $D(DGCST),DGCST<2,'DGCST!$G(DGREL) S DGCFL=1 "RTN","DGPTF41",7,0) W !," PTF ",$J("#"_PTF,7),?15,"actions: 1=Edit C=Close ^N=Another Screen",! "RTN","DGPTF41",8,0) I DGCFL W "CENSUS ",$S(DGCI:$J("#"_DGCI,7),1:" record"),?15,"actions: ",$S(DGCST=1:"P=Open E=Release",1:" L=Close") "RTN","DGPTF41",9,0) S Z="^CLOSE^1 Edit" "RTN","DGPTF41",10,0) I DGCFL S Z=Z_"^"_$S(DGCST=1:"P Open Census^E Release Census",1:"L Close for Census") "RTN","DGPTF41",11,0) W !?15," ^=Abort to Continue: " "RTN","DGPTF41",12,0) D READ "RTN","DGPTF41",13,0) ; "RTN","DGPTF41",14,0) I X="^"!(X="") G Q^DGPTF "RTN","DGPTF41",15,0) I DGCFL,DGCST=1,$E(X)="P"!($E(X)="E") G ACT^DGPTC1 "RTN","DGPTF41",16,0) I DGCFL,'DGCST,$E(X)="L" G ACT^DGPTC1 "RTN","DGPTF41",17,0) I X?1"^".E S DGPTSCRN=701 G ^DGPTFJ "RTN","DGPTF41",18,0) I X?1"C".E,'DGN G CLS^DGPTF4 "RTN","DGPTF41",19,0) I X="O" G O^DGPTF4 "RTN","DGPTF41",20,0) I X="R",DGN G REL "RTN","DGPTF41",21,0) I X'=1 D HELP G EN1^DGPTF4 "RTN","DGPTF41",22,0) S DR="[DG701]",DIE="^DGPT(",(DGPTF,DA)=PTF D ^DIE "RTN","DGPTF41",23,0) F I=0,70 S B(I)="" S:$D(^DGPT(PTF,I)) B(I)=^(I) "RTN","DGPTF41",24,0) K DGPTF,DR "RTN","DGPTF41",25,0) G EN1^DGPTF4 "RTN","DGPTF41",26,0) ; "RTN","DGPTF41",27,0) READ ; -- read X "RTN","DGPTF41",28,0) R X:DTIME S:'$T X="^",DGPTOUT="" D IN^DGHELP "RTN","DGPTF41",29,0) Q "RTN","DGPTF41",30,0) ; "RTN","DGPTF41",31,0) HELP ; "RTN","DGPTF41",32,0) W !,"Enter '1' to edit DXLS & Admit Diagnosis" "RTN","DGPTF41",33,0) W !," 'C' to close out PTF record" "RTN","DGPTF41",34,0) I DGCFL W:DGCST=1 !," 'P' to re-open a Census record",!," 'E' to release a Census record" W:'DGCST !," 'L' to close for Census" "RTN","DGPTF41",35,0) W !," '^' to stop the display" "RTN","DGPTF41",36,0) W !," '^N' to jump to screen #N (appears in upper right of screen '')" "RTN","DGPTF41",37,0) W !," to continue on to the next screen" "RTN","DGPTF41",38,0) R !!,"Enter to continue: ",XS:DTIME "RTN","DGPTF41",39,0) Q "RTN","DGPTF41",40,0) ; "RTN","DGPTF41",41,0) ACT1 ; "RTN","DGPTF41",42,0) W !," PTF ",$J("#"_PTF,7),?15,"actions: O=Open R=Release ^N=Another Screen",! "RTN","DGPTF41",43,0) I $D(DGCST),DGCST=1 W "CENSUS ",$J("#"_DGCI,7),?15,"action : E=Release" "RTN","DGPTF41",44,0) W !?15," ^=Abort to continue: " "RTN","DGPTF41",45,0) S Z="^OPEN^RELEASE PTF^E RELEASE CENSUS" "RTN","DGPTF41",46,0) D READ "RTN","DGPTF41",47,0) I $D(DGCST),DGCST=1,$E(X)="E" G ACT^DGPTC1 "RTN","DGPTF41",48,0) I X=""!(X=U) G Q^DGPTF "RTN","DGPTF41",49,0) I X?1"^".E S DGPTSCRN=701 G ^DGPTFJ "RTN","DGPTF41",50,0) I X="O" G O^DGPTF4 "RTN","DGPTF41",51,0) I X="R" G REL "RTN","DGPTF41",52,0) ; "RTN","DGPTF41",53,0) W !,"Enter 'O' to re-open a PTF record" "RTN","DGPTF41",54,0) W !," 'R' to release a PTF record" "RTN","DGPTF41",55,0) I $D(DGCST),DGCST=1 W !," 'E' to release a Census record" "RTN","DGPTF41",56,0) W !," '^' to stop the display" "RTN","DGPTF41",57,0) W !," '^N' to jump to screen #N (appears in upper right of screen '')" "RTN","DGPTF41",58,0) W !," to continue on to the next screen" "RTN","DGPTF41",59,0) R !!,"Enter to continue: ",XS:DTIME "RTN","DGPTF41",60,0) G EN1^DGPTF4 "RTN","DGPTF41",61,0) ; "RTN","DGPTF41",62,0) REL ; "RTN","DGPTF41",63,0) S Y=1 D RTY^DGPTUTL S DGPTFLE=1,DGPTIFN=PTF D EN^DGPTFREL G ^DGPTF "RTN","DGPTF41",64,0) ; "RTN","DGPTFJ") 0^13^B7406575 "RTN","DGPTFJ",1,0) DGPTFJ ;ALB/MRL - JUMP BETWEEN PTF SCREENS ;4/4/05 2:59pm "RTN","DGPTFJ",2,0) ;;5.3;Registration;**58,517,635**;Aug 13, 1993 "RTN","DGPTFJ",3,0) ; "RTN","DGPTFJ",4,0) TEST K S,M G Q^DGPTF:X="^" S Z="^101^401^501^601^701^801^MAS^CDR",X1=X,X=$P($E(X,2,99),"-",1) G QUES:X1?1"^?".E Q:X="" D IN^DGHELP G QUES:%=-1 "RTN","DGPTFJ",5,0) S Z=$T(@X) I Z="" W !!,"*** Undefined screen number. Valid screens are: ",! G QUES "RTN","DGPTFJ",6,0) I X=4!(X=5) S @($S(+X=5:"DGZM0",1:"DGZS0"))=$S(X1["-":+$P(X1,"-",2),1:1) "RTN","DGPTFJ",7,0) I X=6 S DGZP=$S(X1["-":+$P(X1,"-",2),1:1) "RTN","DGPTFJ",8,0) I X=8 S ANS="F"_$P(X1,"-",2) "RTN","DGPTFJ",9,0) K M,L1,T G @($P(Z,";",3)) "RTN","DGPTFJ",10,0) ; "RTN","DGPTFJ",11,0) HELP W !!,"PTF Screens are: ",! F I=1,5,4,6,7,8,"M","C" S T=$T(@I) Q:T="" W !?5,I,?10,$P(T,";",4) "RTN","DGPTFJ",12,0) Q "RTN","DGPTFJ",13,0) QUES D HELP W !!,"Press Return to continue: " R X:4 "RTN","DGPTFJ",14,0) I $D(DGPTSCRN) S Z=$P($T(@$E(DGPTSCRN)),";",3) K DGPTSCRN G:Z]"" @Z "RTN","DGPTFJ",15,0) G WR^DGPTF1 "RTN","DGPTFJ",16,0) Q G Q^DGPTF "RTN","DGPTFJ",17,0) ; "RTN","DGPTFJ",18,0) PROG ; "RTN","DGPTFJ",19,0) 1 ;;WR^DGPTF1;'101' Screen--Admission/disposition Transaction "RTN","DGPTFJ",20,0) 5 ;;EN^DGPTFM4;'501' Screen--Patient movement transaction "RTN","DGPTFJ",21,0) 4 ;;EN^DGPTFM5;'401' Screen--Surgical/procedure entry "RTN","DGPTFJ",22,0) 6 ;;E^DGPTFM1;'601' Screen--Procedure entry (AVAILABLE FOR DISCHARGES AFTER 10/1/87) "RTN","DGPTFJ",23,0) 7 ;;EN1^DGPTF4;'701' Screen--DXLS/DRG print "RTN","DGPTFJ",24,0) 8 ;;F^DGPTFM2;'801' Screen--CPT entry (CPT and HCPCS) "RTN","DGPTFJ",25,0) M ;;^DGPTFM;'MAS' screen--surgery/procedure/diagnosis code edits "RTN","DGPTFJ",26,0) C ;;EN^DGPTFM7;'CDR' screen--displays CDR information "RTN","DGPTFJ",27,0) Q "RTN","DGPTFJ",28,0) SA ;called from input transform on SOURCE OF ADMISSION field (#20) PTF file (#45) "RTN","DGPTFJ",29,0) S DGER=$S('$D(PTF):1,'$D(^DGPT(PTF,0)):1,1:0) Q:DGER!("^48^49^50^"'[(U_Y_U)) S DGSU1=$P(^(0),"^",5),DGSU0=$S($D(^DGPT(PTF,101)):$P(^(101),"^",6),1:"") "RTN","DGPTFJ",30,0) S DGSTATYP=$S(Y=48:11,Y=49:40,Y=50:30) "RTN","DGPTFJ",31,0) D NUMACT^DGPTSUF(DGSTATYP) "RTN","DGPTFJ",32,0) I DGANUM>0 D "RTN","DGPTFJ",33,0) .I Y=48 F I=1:1:DGANUM S DGER=$S(((DGSU1=DGSUFNAM(DGANUM))!(DGSU1=""))&((DGSU0=DGSUFNAM(DGANUM))!(DGSU0="")):0,1:1) "RTN","DGPTFJ",34,0) .I Y=49!(Y=50) F I=1:1:DGANUM S DGER=$S((Y=49&(DGSU1=DGSUFNAM(DGANUM))&("^9AA^9AB^9AC^9AD^9AE^"[(U_DGSU0_U))):0,(Y=50&(DGSU1=DGSUFNAM(DGANUM))&("^BU^BV^BW^BX^"[(U_DGSU0_U))):0,1:1) "RTN","DGPTFJ",35,0) K DGANUM,DGSTATYP,DGSUFNAM,I "RTN","DGPTFJ",36,0) Q "RTN","DGPTFJC") 0^14^B46752372 "RTN","DGPTFJC",1,0) DGPTFJC ;ALB/ADL - CLOSED PTF ;7/28/05 1:08pm "RTN","DGPTFJC",2,0) ;;5.3;Registration;**158,510,517,590,636,635**;Aug 13, 1993 "RTN","DGPTFJC",3,0) ;;ADL;;Update for CSV Project;;Mar 25, 2003 "RTN","DGPTFJC",4,0) 101 W !,"Enter '^N' for Screen N, RETURN for ,'^' to Abort: //" "RTN","DGPTFJC",5,0) D READ G Q^DGPTF:X=U,^DGPTFM:X="",^DGPTFJ:X?1"^".E D H G 101 "RTN","DGPTFJC",6,0) ; "RTN","DGPTFJC",7,0) H D HELP^DGPTFJ W ! Q "RTN","DGPTFJC",8,0) ; "RTN","DGPTFJC",9,0) MAS W !!,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//" "RTN","DGPTFJC",10,0) D READ G Q^DGPTF:X=U,^DGPTFJ:X?1"^".E "RTN","DGPTFJC",11,0) I X="" S (ST,ST1)=J+2 G @($S($D(DGZDIAG):"NDG",$D(DGZSER):"NSR",$D(DGZPRO):"NPR",$D(DGZSUR):"EN",+DGZPRF-1'=$P(DGZPRF,U,3):"NPS",1:"DONE")_"^DGPTFM") "RTN","DGPTFJC",12,0) D H G MAS "RTN","DGPTFJC",13,0) ; "RTN","DGPTFJC",14,0) 401 S DGNUM=$S($D(S(DGZS0+1)):401_"-"_(DGZS0+1),1:"MAS") "RTN","DGPTFJC",15,0) W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//" "RTN","DGPTFJC",16,0) D READ G Q^DGPTF:X=U,NEXM^DGPTFM5:X="",^DGPTFJ:X?1"^".E D H G 401 "RTN","DGPTFJC",17,0) ; "RTN","DGPTFJC",18,0) 501 W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//" "RTN","DGPTFJC",19,0) D READ G Q^DGPTF:X=U,NEXM^DGPTFM4:X="",^DGPTFJ:X?1"^".E D H G 501 "RTN","DGPTFJC",20,0) ; "RTN","DGPTFJC",21,0) 601 W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//" "RTN","DGPTFJC",22,0) D READ G Q^DGPTF:X=U,NEXP^DGPTFM6:X="",^DGPTFJ:X?1"^".E D H G 601 "RTN","DGPTFJC",23,0) ; "RTN","DGPTFJC",24,0) 701 ; "RTN","DGPTFJC",25,0) G ACT1^DGPTF41 ; new code "RTN","DGPTFJC",26,0) ; "RTN","DGPTFJC",27,0) ;Display screen prompt and process user response for 801 screen "RTN","DGPTFJC",28,0) 801 W !,"Enter '^N' for Screen N, RETURN for <",DGNUM,">,'^' to Abort: <",DGNUM,">//" "RTN","DGPTFJC",29,0) D READ G Q^DGPTF:X=U,NEXP^DGPTFM2:X="",^DGPTFJ:X?1"^".E D H G 801 "RTN","DGPTFJC",30,0) READ ; -- read X "RTN","DGPTFJC",31,0) R X:DTIME S:'$T X="^",DGPTOUT="" "RTN","DGPTFJC",32,0) Q "RTN","DGPTFJC",33,0) ; "RTN","DGPTFJC",34,0) EN ; DG*636 "RTN","DGPTFJC",35,0) ;;S K=$S($D(K):K,1:1),DGER=0 S DGPTDAT=$$GETDATE^ICDGTDRG(DA(1)),DGPTTMP=$$ICDDX^ICDCODE(+Y,DGPTDAT) I +DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGER=1 Q "RTN","DGPTFJC",36,0) S K=$S($D(K):K,1:1),DGER=0 S DGPTDAT=$$GETDATE^ICDGTDRG(DA(1)) "RTN","DGPTFJC",37,0) ;if there is a disch and a previous movement, if disch "RTN","DGPTFJC",38,0) ;is >Oct 1 (next FY) and movement 0930,$E(DGPTMVDT,4,7)<1001 S DGPTDAT=DGPTMVDT Q "RTN","DGPTFJC",45,0) .;if different calendar year "RTN","DGPTFJC",46,0) .I ($E(DGPTDAT,1,3)-$E(DGPTMVDT,1,3))>1 S DGPTDAT=DGPTMVDT Q "RTN","DGPTFJC",47,0) .I $E(DGPTMVDT,4,7)<1001 S DGPTDAT=DGPTMVDT Q "RTN","DGPTFJC",48,0) .I $E(DGPTDAT,4,7)>0930 S DGPTDAT=DGPTMVDT Q "RTN","DGPTFJC",49,0) S DGPTTMP=$$ICDDX^ICDCODE(+Y,DGPTDAT) I +DGPTTMP=-1!('$P(DGPTTMP,U,10)) S DGER=1 Q "RTN","DGPTFJC",50,0) ;end DG*636 "RTN","DGPTFJC",51,0) ;=================================================================== "RTN","DGPTFJC",52,0) I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+^DGPT(DA(1),0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(DGPTTMP,U,2)," can only be used with ",$S($P(DGPTTMP,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",53,0) S %=$P(^DGPT(DA(1),"M",DA,0),U,DGI) I $D(^DGPT(DA(1),"M","AC",Y,DA)),%'=Y S DGER=1 Q "RTN","DGPTFJC",54,0) F I=0:0 S I=$O(^ICD9(+Y,"N",I)) Q:I'>0 I $D(^DGPT(DA(1),"M","AC",I,DA)),%'=I W !,"Cannot use ",$S($D(^ICD9(+Y,0)):$P(^(0),U),1:"")," with ",$S($D(^ICD9(I,0)):$P(^(0),U),1:"") S DGER=1 Q "RTN","DGPTFJC",55,0) Q:DGER S DG1=1 F I=0:0 S I=$O(^ICD9(+Y,"R",I)) Q:I'>0 S DG1=0 I $D(^DGPT(DA(1),"M","AC",I,DA)),%'=I S DG1=1 Q "RTN","DGPTFJC",56,0) I 'DG1 W !,$S(+DGPTTMP>0&('$P(DGPTTMP,U,10)):$P(DGPTTMP,U,2),1:"")," requires additional code." "RTN","DGPTFJC",57,0) Q "RTN","DGPTFJC",58,0) EN1 S K=$S($D(K):K,1:1),DGER=0,DGPTDAT=$$GETDATE^ICDGTDRG(DA(1)),DGICD0=$$ICDOP^ICDCODE(+Y,DGPTDAT) I +DGICD0,0!('$P(DGICD0,U,10)) S DGER=1 Q "RTN","DGPTFJC",59,0) I $P(DGICD0,U,11)]""&($P(DGICD0,U,11)'=$S($D(^DPT(+^DGPT(DA(1),0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(DGICD0,U,2)," can only be used with ",$S($P(DGICD0,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",60,0) S %=$P(^DGPT(DA(1),DGSB,DA,0),U,DGI) I $D(^DGPT(DA(1),DGSB,DGCR,Y,DA)),%'=Y S DGER=1 W !,"Cannot enter the same code more than once within a ",$S(DGSB="S":"401",1:"601")," transaction" Q "RTN","DGPTFJC",61,0) F I=0:0 S I=$O(^ICD0(+Y,"N",I)) Q:I'>0 I $D(^DGPT(DA(1),DGSB,DGCR,I,DA)),%'=I S DGPTTMP2=$$ICDOP^ICDCODE(I,DGPTDAT) W !,"Cannot use ",$P(DGICD0,U,2)," with ",$S(+DGPTTMP2>0:$P(DGPTTMP2,U,2),1:"") S DGER=1 Q "RTN","DGPTFJC",62,0) Q:DGER S DG1=1 F I=0:0 S I=$O(^ICD0(+Y,"R",I)) Q:I'>0 S DG1=0 I $D(^DGPT(DA(1),DGSB,DGCR,I,DA)),%'=I S DG1=1 Q "RTN","DGPTFJC",63,0) I 'DG1 W !,$P(DGICD0,U,2)," requires additional code." "RTN","DGPTFJC",64,0) Q "RTN","DGPTFJC",65,0) EN2 S K=$S($D(K):K,1:1),DGER=0,DGPTTMP=$$ICDOP^ICDCODE(+Y,$$GETDATE^ICDGTDRG(DA)) I +DGPTTMP<0!('$P(DGPTTMP,U,10)) S DGER=1 Q "RTN","DGPTFJC",66,0) I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+^DGPT(DA,0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(DGPTTMP,U,2)," can only be used with ",$S($P(DGPTTMP,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",67,0) S L=$P($S($D(^DGPT((DA),"401P")):^("401P"),1:0),U,1,5),%=$P(L,U,DGI),L=$P(L,U,1,DGI-1)_U_$P(L,U,DGI+1,5) I L[Y S DGER=1 Q "RTN","DGPTFJC",68,0) Q "RTN","DGPTFJC",69,0) EN3 S K=$S($D(K):K,1:1),DGER=0,DGPTTMP=$$ICDDX^ICDCODE(+Y,$$GETDATE^ICDGTDRG(DA)) I +DGPTTMP<0!('$P(DGPTTMP,U,10)) S DGER=1 Q "RTN","DGPTFJC",70,0) I DGI=1,$P(DGPTTMP,U,5) S DGER=1 Q "RTN","DGPTFJC",71,0) I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+^DGPT(DA,0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(DGPTTMP,U,2)," can only be used with ",$S($P(DGPTTMP,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",72,0) S %=$S($D(^DGPT(DA,70)):^(70),1:""),%=U_$P(%,U,10)_U_$P(%,U,16,24)_U "RTN","DGPTFJC",73,0) S:$G(^DGPT(DA,71))'="" %=%_^(71)_U S $P(%,U,DGI+1)=U I %[(U_+Y_U) S DGER=1 Q "RTN","DGPTFJC",74,0) F I=0:0 S I=$O(^ICD9(+Y,"N",I)) Q:I'>0 I %[(U_I_U) S DGPTTMP2=$$ICDDX^ICDCODE(I,DGPTDAT) W !,"Cannot use ",$P($G(DGPTTMP),U,2)," with ",$S(+DGPTTMP2>0:$P(DGPTTMP2,U,2),1:"") S DGER=1 Q "RTN","DGPTFJC",75,0) Q:DGER S DG1=1 F I=0:0 S I=$O(^ICD9(+Y,"R",I)) Q:I'>0 S DG1=0 I %[(U_I_U) S DG1=1 Q "RTN","DGPTFJC",76,0) I 'DG1 W !,$S(+DGPTTMP>0:$P(DGPTTMP,U,2),1:"")," requires additional code." "RTN","DGPTFJC",77,0) Q "RTN","DGPTFJC",78,0) EN4 S K=$S($D(K):K,1:1),DGER=0,N=$$ICDDX^ICDCODE(+Y,$$GETDATE^ICDGTDRG(DA)) I N<0!'$P(N,U,10) S DGER=1 Q "RTN","DGPTFJC",79,0) I DGI=1,$P(N,U,5) S DGER=1 Q "RTN","DGPTFJC",80,0) I $P(N,U,11)]""&($P(N,U,11)'=$S($D(^DPT(+^DGPT(DA(2),0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(N,U,2)," can only be used with ",$S($P(N,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",81,0) S %=$S($D(^DGPT(DA(2),"C",DA(1),"CPT",DA,0)):^(0),1:""),%=U_$P(%,U,4,7)_U,$P(%,U,DGI+1)=U I %[(U_+Y_U) S DGER=1 Q "RTN","DGPTFJC",82,0) F I=0:0 S I=$O(^ICD9(+Y,"N",I)) Q:I'>0 I %[(U_I_U) W !,"Cannot use ",$S($D(^ICD9(+Y,0)):$P(^(0),U),1:"")," with ",$S($D(^ICD9(I,0)):$P(^(0),U),1:"") S DGER=1 Q "RTN","DGPTFJC",83,0) Q:DGER S DG1=1 F I=0:0 S I=$O(^ICD9(+Y,"R",I)) Q:I'>0 S DG1=0 I %[(U_I_U) S DG1=1 Q "RTN","DGPTFJC",84,0) I 'DG1 W !,$P(N,U,2)," requires additional code." Q "RTN","DGPTFJC",85,0) Q "RTN","DGPTFJC",86,0) EN5 S K=$S($D(K):K,1:1),DGER=0,DGPTTMP=$$ICDDX^ICDCODE(+Y,+DGZPRF(DGZP)) I +DGPTTMP<0!('$P(DGPTTMP,U,10)) S DGER=1 Q "RTN","DGPTFJC",87,0) I $P(DGPTTMP,U,11)]""&($P(DGPTTMP,U,11)'=$S($D(^DPT(+^DGPT(PTF,0),0)):$P(^(0),U,2),1:"M")) W:K<24 !,$P(DGPTTMP,U,2)," can only be used with ",$S($P(DGPTTMP,U,11)="F":"FEMALES",1:"MALES") S K=K+1,DGER=1 Q "RTN","DGPTFJC",88,0) S K=^DGCPT(46,DA,0) I $P(K,U,4,7)_U_$P(K,U,15,18)[Y S DGER=1 Q "RTN","DGPTFJC",89,0) Q "RTN","DGPTFJC",90,0) EN6 I $P($G(^(0)),U,2)?.N S DGER=1 Q "RTN","DGPTFJC",91,0) S DGER=0,N=$$CPT^ICPTCOD(+Y,$$GETDATE^ICDGTDRG(DA)) I N<0!'$P(N,"^",7) S DGER=1 Q "RTN","DGPTFJC",92,0) S L=0 F S L=$O(^DGCPT(46,L)) Q:L'>0 I +$G(^(L,1))=DGPRD,$P(^(1),U,3)=PTF,+^(0)=Y,'$G(^(9)) S DGER=1 Q "RTN","DGPTFJC",93,0) K L Q "RTN","DGPTFM") 0^2^B43402022 "RTN","DGPTFM",1,0) DGPTFM ;ALB/MTC - PTF OP-PRO-DIAG ;7/22/05 9:18am "RTN","DGPTFM",2,0) ;;5.3;Registration;**510,517,590,594,606,635**;Aug 13, 1993 "RTN","DGPTFM",3,0) K M,S,M1,M2,M3,S1,S2,PS2,SDCLY,^TMP("PTF",$J) "RTN","DGPTFM",4,0) GET S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:'I S (M3(I1),M(I1))=^(I,0) I $D(^DGPT(PTF,"M",I,"P")) S $P(M(I1),U,20)=^("P") "RTN","DGPTFM",5,0) K MT D ORDER^DGPTF K MT D GETVAR^DGPTFM6,CL^SDCO21(DFN,$P(^DGPT(PTF,0),U,2),"",.SDCLY),MOB^DGPTFM2 "RTN","DGPTFM",6,0) S DGPC=I1-1 D WR K M1,M2,^UTILITY($J) S ST=1,M2=0 "RTN","DGPTFM",7,0) DIAG K DGZSER,DGZPRO,DGZSUR S DGZDIAG=1 F J=ST:2:PM S NL=1,L5=0,L6=J D WD2 S L5=1,L6=J+1 D:$D(M(L6)) WD2 D WD G PRO1:$Y>16 D WD3^DGPTFM8 G PRO1:$Y>16 W ! "RTN","DGPTFM",8,0) S ST=1 G SER "RTN","DGPTFM",9,0) WD F J1=1:1:11 I J1'=6 S L=$P(M(J),U,J1+4),L1=0,L3=1 D:+L WD1 S L1=1,L=$S($D(M(J+1)):$P(M(J+1),U,J1+4),1:"") D:+L WD1 "RTN","DGPTFM",10,0) Q "RTN","DGPTFM",11,0) WD1 S N=$$ICDDX^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S(N:$P(N,U,2,99),1:""),M2=M2+1,L4=$P(L2,"^",1),L4=L4_$E(" ",1,3-$L($P(L4,".",2))) "RTN","DGPTFM",12,0) W:L3 ! S:L3 L3=0 W ?L1*40,$J(M2,3)," ",$J(L4,7)," ",$E($P(L2,U,3),1,25) K ^UTILITY($J,"M2",M2) S ^UTILITY($J,"M2",M2)=+M(J+L1)_U_J1 Q "RTN","DGPTFM",13,0) WD2 N Z3 "RTN","DGPTFM",14,0) X:NL "W ! S NL=0" W ?L5*40,"Move #",+L6 S Z=M(L6),Z3=M3(L6) W:+Z=1 " D/C" S Y=$P(Z,U,10)\1 D D^DGPTUTL W " ",Y," ",$S($D(^DIC(42.4,+$P(Z,U,2),0)):$E($P(^(0),U,1),1,10),1:"") "RTN","DGPTFM",15,0) W " <",$S($P(Z3,U,18)=1:"",1:"N"),"SC"_$S($P(Z3,U,26)="Y":",AO",1:"")_$S($P(Z3,U,27)="Y":",IR",1:"")_$S($P(Z3,U,28)="Y":",EC",1:"")_">" "RTN","DGPTFM",16,0) Q "RTN","DGPTFM",17,0) NDG D WR S I=0 K M,M1,M2 S M2=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 S M(I1)=^(I,0) "RTN","DGPTFM",18,0) S PM=I1-1 D ORDER^DGPTF K MT G DIAG:$D(ST) G GET S ST=1 "RTN","DGPTFM",19,0) SER K DGZDIAG,DGZPRO,DGZSUR S DGZSER=1 G PRO1:$Y>19 K S1,S2 S S2=0 G SERV:ST G PRO "RTN","DGPTFM",20,0) SERV F J=ST:2:SU S NL=1,L5=0,L6=J D SD2 S L5=1,L6=J+1 D:$D(S(L6)) SD2 D SD G PRO1:$Y>11 D SD3^DGPTFM8 G PRO1:$Y>11 W ! "RTN","DGPTFM",21,0) G PRC^DGPTFM0 "RTN","DGPTFM",22,0) SD F J1=1:1:5 S L=$P(S(J),U,J1+7),L1=0,L3=1 D:+L SD1 S L1=1,L=$S($D(S(J+1)):$P(S(J+1),U,J1+7),1:"") D:+L SD1 "RTN","DGPTFM",23,0) Q "RTN","DGPTFM",24,0) SD1 S N=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S(N:$P(N,U,2,99),1:""),S2=S2+1,L4=$P(L2,"^",1),L4=L4_$E(" ",1,3-$L($P(L4,".",2))) "RTN","DGPTFM",25,0) W:L3 ! S:L3 L3=0 W ?L1*40,$J(S2,3)," ",$J(L4,7)," ",$E($P(L2,U,4),1,25) K S2(S2) S S2(S2)=J+L1_U_J1 Q "RTN","DGPTFM",26,0) SD2 S Y=+S(L6) D D^DGPTUTL W:NL ! S:NL NL=0 W ?L5*40,L6,"-Surgery date: ",Y "RTN","DGPTFM",27,0) Q "RTN","DGPTFM",28,0) NSR K S,S1,S2 S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"S",I)) Q:I'>0 S S(I1)=^(I,0),S(I1,1)=I "RTN","DGPTFM",29,0) S S2=0,SU=I1-1 D WR G SERV "RTN","DGPTFM",30,0) ; "RTN","DGPTFM",31,0) WR W @IOF,HEAD,?70 S Z="" D Z Q "RTN","DGPTFM",32,0) PRO K DGZSER,DGZDIAG,DGZSUR S DGZPRO=1 G PRO1:$Y>14 K P1,P2 S ST=1,P2=0 G NPR:'$D(PROC) "RTN","DGPTFM",33,0) PROC D:$Y>14 WR W:PROC]"" !!,"Procedures: ",! "RTN","DGPTFM",34,0) F J1=1:1:5 S L=$P(PROC,"^",J1) I L'="" S P2=P2+1,N=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S(N:$P(N,U,2,99),1:""),L4=$P(L2,U,1),L4=L4_$E(" ",1,3-$L($P(L4,".",2))) D "RTN","DGPTFM",35,0) .W:$X>5 ?40 W $J(P2,3)," ",$J(L4,7)," ",$E($P(L2,"^",4),1,25) K P2(P2) S P2(P2)=J1 W:$X>45 ! "RTN","DGPTFM",36,0) K DGZSER,DGZPRO,DGZDIAG,DGZSUR "RTN","DGPTFM",37,0) ENC G PRO1:$Y>7,PRO1:'$P(DGZPRF,U,3) "RTN","DGPTFM",38,0) PF S PS2=0,J=+DGZPRF,Y=+DGZPRF(J),DGSTRT=$S(+$P(DGZPRF,U,4):$P(DGZPRF,U,4),1:4),DGLST=0 "RTN","DGPTFM",39,0) D CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY),ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21 ; load SCI info and DGN's for this service date "RTN","DGPTFM",40,0) D D^DGPTUTL W !,J,"-CPT Capture Date/Time: ",Y W:($P(DGZPRF,U,2)-1!($G(PGBRK))) " (cont.)" "RTN","DGPTFM",41,0) I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " S L=$P(DGZPRF(J),U,2) D PRV "RTN","DGPTFM",42,0) W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV "RTN","DGPTFM",43,0) I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U) "RTN","DGPTFM",44,0) S (L1,PGBRK)=0 "RTN","DGPTFM",45,0) F K=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K)) I '$G(DGZPRF(J,K,9)) S PS2=PS2+1 W !,?2,PS2," " D CPT^DGPTUTL1 D Q:$Y+$G(DGZPRF(J,K+1,1))>16!($G(PGBRK)) "RTN","DGPTFM",46,0) . W !,?4 S $P(DS,"-",27)="" W DS," Related Diagnosis ",DS "RTN","DGPTFM",47,0) . F L1=DGSTRT:1:11 S DGLOC=$S(L1<8:L1,1:L1+7),CD=$P(DGZPRF(J,K),U,DGLOC) I CD D I $Y+$G(CKSCI)>16 S PGBRK=1 Q "RTN","DGPTFM",48,0) . . S N=$$ICDDX^ICDCODE(CD,$$GETDATE^ICDGTDRG(PTF)),N=$S(N:$P(N,U,2,99),1:"") "RTN","DGPTFM",49,0) . . S CD=$P(N,U) W !,?8,CD," ",$P(N,U,3) "RTN","DGPTFM",50,0) . . D CKSCI($P(DGZPRF(J,K),U,DGLOC)) "RTN","DGPTFM",51,0) . S PS2(PS2)=J_U_K,CD=1,DGLOC=0,DGSTRT=4 "RTN","DGPTFM",52,0) I L1'=11,$S(L1<8:$P($G(DGZPRF(J,K)),U,L1+1,7),1:"")_$P($G(DGZPRF(J,K)),U,$S(L1<8:15,1:L1+8),18)?."^" S L1=11 "RTN","DGPTFM",53,0) I L1=11 S $P(DGZPRF,U,1,2)=$S($D(DGZPRF(J,K+1)):J_U_(K+1),1:J+1_U_1),$P(DGZPRF,U,4)="",PGBRK=0 "RTN","DGPTFM",54,0) E S $P(DGZPRF,U,1,2)=J_U_K,$P(DGZPRF,U,4)=L1+1 "RTN","DGPTFM",55,0) ;I '$D(DGZPRF(J,K+1)) S $P(DGZPRF,U,1,2)=$S($P($G(DGZPRF(J,K)),U,NXTDGN)'="":J,1:J+1)_U_1,$P(DGZPRF,U,4)=DGLST "RTN","DGPTFM",56,0) ;I $D(DGZPRF(J,K+1)) S $P(DGZPRF,U,1,2)=J_U_(K+1) "RTN","DGPTFM",57,0) K I,K,L,L1,CD,N G PRO1 "RTN","DGPTFM",58,0) ; "RTN","DGPTFM",59,0) CKSCI(IEN) ;print SCI for each Diagnosis code "RTN","DGPTFM",60,0) N DGINFO Q:'$D(XREF(IEN)) "RTN","DGPTFM",61,0) S DGINFO=$G(^DGICD9(46.1,(XREF(IEN)),0)),CKSCI=0 "RTN","DGPTFM",62,0) I 'DGINFO Q "RTN","DGPTFM",63,0) F I=3,7,1,2,4:1:6 I $D(SDCLY(I)) S L=$S(I=3:8,I<4:8+I,1:7+I) D "RTN","DGPTFM",64,0) .W ?45 S M=1,CKSCI=CKSCI+1 "RTN","DGPTFM",65,0) .W $P("Treated for AO Condition^Treated for IR Condition^Treated for SC Condition^Exposed to Envir Contaminants^Treatment for MST^Treatment for Head/Neck CA^Related to Combat",U,I) "RTN","DGPTFM",66,0) .I I'=7 W ":",$S($P(DGINFO,U,($S(I<3:I+2,I=3:2,1:I+1))):"YES",1:"NO"),! "RTN","DGPTFM",67,0) .I I=7 W ":",$S($P(DGINFO,U,8)="Y":"YES",1:"NO"),! "RTN","DGPTFM",68,0) Q ;CKSCI "RTN","DGPTFM",69,0) ; "RTN","DGPTFM",70,0) NPR S ST=1,PROC=$S($D(^DGPT(PTF,"401P")):^("401P"),1:"") D WR G PRO "RTN","DGPTFM",71,0) ; "RTN","DGPTFM",72,0) NPS D WR G PF "RTN","DGPTFM",73,0) ; "RTN","DGPTFM",74,0) DONE G EN1^DGPTF4 "RTN","DGPTFM",75,0) PRO1 ;SET MENU TYPE AND DISPLAY MENU "RTN","DGPTFM",76,0) N ICDVDT,ICPTVDT "RTN","DGPTFM",77,0) S (ICDVDT,ICPTVDT)=$S($D(PTF):$$GETDATE^ICDGTDRG(PTF),1:DT) "RTN","DGPTFM",78,0) S DGNUM=$S($D(DGZDIAG)!($D(DGZPRO))!($D(DGZSER))!($D(DGZSUR)!(+DGZPRF-1'=$P(DGZPRF,U,3))):"MAS",1:"701") G MAS^DGPTFJC:DGST F X=$Y:1:(IOSL-8) W ! "RTN","DGPTFM",79,0) W !! S Z="Patient Movements:" W Z S Z=" "_$S(DGPTFE:"M=Add PM X=Delete PM",1:"M=Edit Treat Spec/PM ")_" A=Add Code D=Delete Code V=Edit Mov" W Z "RTN","DGPTFM",80,0) W ! S Z="Surgical Episodes:" W Z S Z=" S=Add SE Z=Delete SE O=Add Code C=Delete Code J=Edit SE" W Z "RTN","DGPTFM",81,0) W ! S Z="Procedure Records:" W Z S Z=" T=Add PR R=Delete PR P=Add Code Q=Delete Code E=Edit PR" W Z "RTN","DGPTFM",82,0) W ! S Z="801:" W Z S Z=" I=Add 801 Y=Delete 801 N=Add CPT G=Delete CPT F=Edit 801" W Z K Z "RTN","DGPTFM",83,0) W !," ^=Abort to Continue:<",DGNUM,">// " R ANS:DTIME K DGNUM "RTN","DGPTFM",84,0) A S Z="^C Delete Code^A Add Code^O Add Code^P Add NOP^S Add SE^D Delete Code^M Add PM^X Delete PM^Z Delete SE^J Edit SE^Q Delete NOP^V Edit Move^" "RTN","DGPTFM",85,0) S Z=Z_"T Add PR^R Delete PR^E Edit PR^I Add 801^Y Delete 801^N Add CPT^G Delete CPT^F Edit 801" "RTN","DGPTFM",86,0) I 'DGPTFE S $P(Z,U,8,9)="M Edit treat Spec/PM" "RTN","DGPTFM",87,0) S X=ANS G Q^DGPTF:ANS="^" G ^DGPTFJ:ANS?1"^".E S (A,X)=ANS,X=$E(X,1) D IN^DGHELP "RTN","DGPTFM",88,0) I $P(^DGPT(PTF,0),U,4),X'="","IYNGF"[X W !,"***WARNING: This is a Fee Basis PTF record*** 801 encounters are not allowed." H 3 G DGPTFM "RTN","DGPTFM",89,0) I ANS="" S (ST,ST1)=J+2 D:$D(DGZSUR) WR G @($S($D(DGZDIAG):"NDG",$D(DGZSER):"NSR",$D(DGZPRO):"NPR",$D(DGZSUR):"EN^DGPTFM0",+DGZPRF-1'=$P(DGZPRF,U,3):"NPS",1:"DONE")) "RTN","DGPTFM",90,0) G HELP^DGPTFM1A:%=-1 S Z=$L(A)-1 G @(X_$S(X="X":"",1:"^DGPTFM1")) "RTN","DGPTFM",91,0) PRV I $D(^VA(200,L,0)) W $P(^(0),U) Q "RTN","DGPTFM",92,0) W L Q "RTN","DGPTFM",93,0) X ; "RTN","DGPTFM",94,0) I 'Z S:PM=1 RC=1 G X1:PM=1 W !!,"Delete Patient move <1",$S(PM<3:"",1:"-"_(PM-1)),">: " R RC:DTIME G ^DGPTFM:RC["^"!(RC="") "RTN","DGPTFM",95,0) E S RC=$E(A,2,99) W ! "RTN","DGPTFM",96,0) I +RC'=RC!('$D(M(RC))) W !!,"Enter the record # to delete from the PTF file, 1",$S(PM<3:"",1:"-"_(PM-1)) S Z=0 G X "RTN","DGPTFM",97,0) X1 I +M(RC)=1 W !,*7,"Cannot delete discharge movement",! H 3 G ^DGPTFM "RTN","DGPTFM",98,0) S DIE="^DGPT("_PTF_",""M"",",DP=45.02,DR=".01///@",DA(1)=PTF,DA=+M(RC) D ^DIE K DR W " ",RC,"-DELETED***" H 2 G ^DGPTFM "RTN","DGPTFM",99,0) Z W @DGVI,Z,@DGVO Q "RTN","DGPTFM",100,0) EN D WR G EN^DGPTFM0 "RTN","DGPTFM1") 0^15^B19186087 "RTN","DGPTFM1",1,0) DGPTFM1 ;ALB/MTC - MASTER DIAG/OP/PRO CODE ENTER/EDIT ;4/4/05 3:08pm "RTN","DGPTFM1",2,0) ;;5.3;Registration;**114,517,635**;Aug 13, 1993 "RTN","DGPTFM1",3,0) ; "RTN","DGPTFM1",4,0) D G D^DGPTFM0 "RTN","DGPTFM1",5,0) ; "RTN","DGPTFM1",6,0) A S L="" F I=1:1:PM S L2=1 F J=5:1:9 I L2&(J'=10)&($P(M(I),U,J)="") S L=L_I_",",L2=0 "RTN","DGPTFM1",7,0) I L="" W !!,"There are no movement records that can be added to.",*7,*7 H 2 G ^DGPTFM "RTN","DGPTFM1",8,0) S L=$E(L,1,$L(L)-1) I L=+L S RC=+L G A2 "RTN","DGPTFM1",9,0) A1 I 'Z W !!,"Add to movement record <",L,"> : " R RC:DTIME G ^DGPTFM:RC[U!('$T)!(RC="") "RTN","DGPTFM1",10,0) E S RC=+$E(A,2,99) "RTN","DGPTFM1",11,0) A2 I +RC'=RC!(","_L_","'[(","_RC_",")) W !!,"Enter the movement record number to add ICD diagnosis to: ",L S Z="" G A1 "RTN","DGPTFM1",12,0) S DIE="^DGPT(",(DA,DGPTF)=PTF,DR="[DG501]",DGJUMP="" "RTN","DGPTFM1",13,0) S DGMOV=+M(RC),DGADD=1 D ^DIE K DR,DA,DGADD,DIE,DGJUMP D CHK501^DGPTSCAN K DGPTF,DGMOV,DGADD "RTN","DGPTFM1",14,0) G ^DGPTFM "RTN","DGPTFM1",15,0) ; "RTN","DGPTFM1",16,0) M I DGPTFE G ADD^DGPTFM4 "RTN","DGPTFM1",17,0) S X=80 X ^%ZOSF("RM") D MVT K T,AM,M I $L(DGVO_DGVI)>4 S X=132 X ^%ZOSF("RM") "RTN","DGPTFM1",18,0) G ^DGPTFM:'$D(DGPMDA) S DA=$S('$D(^DGPM(DGPMDA,"PTF")):"",1:$P(^("PTF"),"^",3)) G ^DGPTFM:'$D(^DGPT(PTF,"M",+DA,0)) S Y=^(0) "RTN","DGPTFM1",19,0) S X=$S($D(^DIC(42.4,+$P(Y,U,2),0)):$P(^(0),U,1),1:""),Y=$P(Y,U,10) "RTN","DGPTFM1",20,0) D D^DGPTUTL K M W !,"Editing ",$S(DA=1:"Discharge ",1:""),"Movement " W:Y]"" "of ",Y W " Losing Specialty ",X "RTN","DGPTFM1",21,0) S DGMOV=DA,(DA,DGPTF)=PTF,DIE="^DGPT(",DR="[DG501]",DGJUMP="1-2" D ^DIE "RTN","DGPTFM1",22,0) K DA,DR,DIE,DGJUMP D CHK501^DGPTSCAN K DGPTF,DGMOV "RTN","DGPTFM1",23,0) ;- update MT indicator after edit movement "RTN","DGPTFM1",24,0) N DGPMCA,DGPMAN D PM^DGPTUTL "RTN","DGPTFM1",25,0) I '$G(DGADM) S DGADM=+^DGPT(PTF,0) "RTN","DGPTFM1",26,0) D MT^DGPTUTL "RTN","DGPTFM1",27,0) G ^DGPTFM "RTN","DGPTFM1",28,0) ; "RTN","DGPTFM1",29,0) Z I 'SU W !,"No surgeries to delete",! H 3 G ^DGPTFM "RTN","DGPTFM1",30,0) S ST=1 I 'Z W !!,"Delete surgery record <1",$S(SU=1:"",1:"-"_SU),">: " R RC:DTIME G ^DGPTFM:'$T!(RC[U)!(RC="") "RTN","DGPTFM1",31,0) E S RC=$E(A,2,99) W ! "RTN","DGPTFM1",32,0) I +RC'=RC!('$D(S(RC))) W !!,"Enter the record # to delete from the PTF file, 1",$S(SU=1:"",1:"-"_SU) S Z=0 G Z "RTN","DGPTFM1",33,0) K DA S DIK="^DGPT("_PTF_",""S"",",ST=1,(DGPTF,DA(1))=PTF,(DGSUR,DA)=+S(RC,1) D ^DIK K DA W " ",RC,"-DELETED***" D CHK401^DGPTSCAN K DGPTF,DGSUR H 2 G ^DGPTFM "RTN","DGPTFM1",34,0) ; "RTN","DGPTFM1",35,0) C G CEL:Z "RTN","DGPTFM1",36,0) I '$D(S2) W !,"View codes first",! H 2 G ^DGPTFM "RTN","DGPTFM1",37,0) I 'S2 W !,"No codes to delete",! H 2 G ^DGPTFM "RTN","DGPTFM1",38,0) C1 R !!,"Enter the item #'s of the ICD operation codes to delete: ",A1:DTIME "RTN","DGPTFM1",39,0) S:'$T A1=U I A1'?1N.NP G ^DGPTFM:"^"[A1 W:A1'["?" " ???",*7 D C^DGPTFM0 G C1 "RTN","DGPTFM1",40,0) S A=A_A1 "RTN","DGPTFM1",41,0) CEL D EXPL^DGPTUTL "RTN","DGPTFM1",42,0) K X,A1 S DA(1)=PTF,DP=45.01 W !! "RTN","DGPTFM1",43,0) F J=1:1 S L=+$P(DGA,",",J),DIE="^DGPT("_PTF_",""S""," Q:'L D "RTN","DGPTFM1",44,0) .S L1=$S($D(S2(L)):S2(L),1:"Undefined, ") W:'L1 " ",L,"-",L1 "RTN","DGPTFM1",45,0) .I L1 S (DA,DGSUR)=+S(+L1,1),(DA(1),DGPTF)=PTF,DR=7+$P(S2(+L),U,2)_"///@" D ^DIE,CEL1 "RTN","DGPTFM1",46,0) H 3 S ST=1 G ^DGPTFM "RTN","DGPTFM1",47,0) ; "RTN","DGPTFM1",48,0) CEL1 ; "RTN","DGPTFM1",49,0) K DR W " ",L,"-Deleted, " W:$X>70 ! D CHK401^DGPTSCAN K DGPTF,DGSUR "RTN","DGPTFM1",50,0) Q "RTN","DGPTFM1",51,0) ; "RTN","DGPTFM1",52,0) O S L="" F I=1:1:SU S L2=1 F J=8:1:12 I L2,$P(S(I),U,J)="" S L=L_I_",",L2=0 "RTN","DGPTFM1",53,0) I L="" W !!,"There are no surgery records that can be added to.",*7 H 2 S ST=1 G ^DGPTFM "RTN","DGPTFM1",54,0) S L=$E(L,1,$L(L)-1) I L=+L S RC=+L G O2 "RTN","DGPTFM1",55,0) O1 I 'Z S ST=1 W !!,"Add to surgery record <",L,"> : " R RC:DTIME G ^DGPTFM:'$T!(RC[U)!(RC="") "RTN","DGPTFM1",56,0) E S RC=+$E(A,2,99) "RTN","DGPTFM1",57,0) O2 I +RC'=RC!(","_L_","'[(","_RC_",")) W !!,"Enter the surgery record number to add ICD operation codes to: ",L G O1:'Z S Z="" G O1 "RTN","DGPTFM1",58,0) S DIE="^DGPT(",(DGPTF,DA)=PTF,DR="[DG401]" "RTN","DGPTFM1",59,0) S ST=1,DGZS0=RC,DGADD=1,DGSUR=S(DGZS0,1) D ^DIE,CHK401^DGPTSCAN K DR,DGPTF,DGSUR,DGADD G ^DGPTFM "RTN","DGPTFM1",60,0) ; "RTN","DGPTFM1",61,0) S G ADD^DGPTFM5 "RTN","DGPTFM1",62,0) V S DGZM0=0 G ^DGPTFM4 "RTN","DGPTFM1",63,0) J S DGZS0=0 G ^DGPTFM5 "RTN","DGPTFM1",64,0) Q G QEL:Z "RTN","DGPTFM1",65,0) QQ R !!,"Enter the item #'s of the ICD Procedure codes to delete: ",A1:DTIME "RTN","DGPTFM1",66,0) S:'$T A1=U I A1'?1N.NP G ^DGPTFM:"^"[A1 W:A1'["?" " ???",*7 D Q^DGPTFM0 G QQ "RTN","DGPTFM1",67,0) S A=A_A1 "RTN","DGPTFM1",68,0) QEL S DGA=$E(A,2,999) K X,A1 S DIE="^DGPT(",DA=PTF W !! "RTN","DGPTFM1",69,0) F J=1:1 S DP=45,L=+$P(DGA,",",J) Q:'L S L1=$S($D(P2(L)):P2(L),1:"Undefined, ") W:'L1 " ",L,"-",L1 I L1 S DR=+P2(+L)/100+45_"///@",DA(1)=PTF D ^DIE K DR W " ",L,"-Deleted, " W:$X>70 ! "RTN","DGPTFM1",70,0) H 2 G ^DGPTFM "RTN","DGPTFM1",71,0) ; "RTN","DGPTFM1",72,0) P G P^DGPTFM6 "RTN","DGPTFM1",73,0) Q1 Q "RTN","DGPTFM1",74,0) T G ^DGPTFM6 "RTN","DGPTFM1",75,0) R G R^DGPTFM4 "RTN","DGPTFM1",76,0) E I $D(^DGPT(PTF,70)),+^(70)>2871000 D MOB^DGPTFM6 G SET^DGPTFM6 "RTN","DGPTFM1",77,0) I DT>2871000 D MOB^DGPTFM6 G SET^DGPTFM6 "RTN","DGPTFM1",78,0) G ^DGPTFM6 "RTN","DGPTFM1",79,0) ; "RTN","DGPTFM1",80,0) MVT ; "RTN","DGPTFM1",81,0) N PTF,DGPMAN "RTN","DGPTFM1",82,0) S DGPMT=6 D CA^DGPMV S DGPMDA=+Y "RTN","DGPTFM1",83,0) K DGPMT Q "RTN","DGPTFM1",84,0) I G ADD^DGPTFM2 "RTN","DGPTFM1",85,0) Y G DEL^DGPTFM2 "RTN","DGPTFM1",86,0) N G N^DGPTFM2 "RTN","DGPTFM1",87,0) G G DC^DGPTFM2 "RTN","DGPTFM1",88,0) F G F^DGPTFM2 "RTN","DGPTFM1A") 0^16^B6978809 "RTN","DGPTFM1A",1,0) DGPTFM1A ;ALB/JDS - MASTER DIAG/OP/PRO CODE HELP ;3/28/05 1:05pm "RTN","DGPTFM1A",2,0) ;;5.3;Registration;**517,635**;Aug 13, 1993 "RTN","DGPTFM1A",3,0) ; "RTN","DGPTFM1A",4,0) HELP W !!,"Enter ",?10,"'A'-To add an ICD diagnosis",!?10 W:DGPTFE "'M'-To add a new patient movement",!?10,"'X'-To delete a patient movement" "RTN","DGPTFM1A",5,0) W:'DGPTFE "'M'-To edit treating specialty transfers which generate",!,?14,"patient movements" "RTN","DGPTFM1A",6,0) W !?10,"'S'-To add a new surgery record" "RTN","DGPTFM1A",7,0) W !?10,"'T'-To add a new procedure record" "RTN","DGPTFM1A",8,0) W !?10,"'I'-To add a new 801 record" "RTN","DGPTFM1A",9,0) W !?10,"'Z'-To delete a surgery record" "RTN","DGPTFM1A",10,0) W !?10,"'R'-To delete a procedure record" "RTN","DGPTFM1A",11,0) W !?10,"'Y'-To delete an 801 record." "RTN","DGPTFM1A",12,0) W !?10,"'A'-To add an ICD diagnosis" "RTN","DGPTFM1A",13,0) W !?10,"'O'-To add an ICD op code" "RTN","DGPTFM1A",14,0) W !?10,"'P'-To add a new ICD procedure code" "RTN","DGPTFM1A",15,0) W !?10,"'N'-To add a CPT procedure code" "RTN","DGPTFM1A",16,0) W !?10,"'D'-To delete an ICD diagnosis" "RTN","DGPTFM1A",17,0) W !?10,"'C'-To delete a ICD op code" "RTN","DGPTFM1A",18,0) W !?10,"'Q'-To delete a ICD procedure code" "RTN","DGPTFM1A",19,0) W !?10,"'G'-To delete a CPT procedure code" "RTN","DGPTFM1A",20,0) W !?10,"'V'-To review all patient movements",!?10,"'J'-To review all surgery segments" "RTN","DGPTFM1A",21,0) W !?10,"'E'-To review all procedure segments" "RTN","DGPTFM1A",22,0) W !?10,"'F'-To review all 801 segments" "RTN","DGPTFM1A",23,0) W !?10,"'^' to abort",!?10," to continue on to the next screen" "RTN","DGPTFM1A",24,0) R !,"Enter to continue: ",ANS:DTIME K ANS "RTN","DGPTFM1A",25,0) W !,"The delete codes (D,C,Q,G) may be followed by the numbers that are before the",!,"ICD codes, separated by commas. ('D1,2,8' to delete ICD diagnoses 1,2 and 8",!,"if they were on the screen above)" "RTN","DGPTFM1A",26,0) W !!,"The edit code F may be followed by a number to start editing" "RTN","DGPTFM1A",27,0) W !,"the 801 records at that number record." "RTN","DGPTFM1A",28,0) R !!,"Enter to continue: ",ANS:DTIME K ANS G ^DGPTFM "RTN","DGPTFM2") 0^3^B46843310 "RTN","DGPTFM2",1,0) DGPTFM2 ;ALB/DWS - MASTER PROFESSIONAL SERVICE ENTER/EDIT ;6/16/05 8:33am "RTN","DGPTFM2",2,0) ;;5.3;Registration;**517,590,606,635**;Aug 13, 1993 "RTN","DGPTFM2",3,0) ADD ;ADD CPT RECORD "RTN","DGPTFM2",4,0) N DGZP S DGZP=0 S:'$D(^DGPT(PTF,"C",0)) ^(0)="^45.06D^^" "RTN","DGPTFM2",5,0) S DIC="^DGPT("_PTF_",""C"",",DIC(0)="AELQMXZ",DA(1)=PTF,DLAYGO=45 "RTN","DGPTFM2",6,0) D ^DIC K DIC,DLAYGO G ^DGPTFM:Y'>0,^DGPTFM:'$D(^DGPT(PTF,"C",+Y)) "RTN","DGPTFM2",7,0) S DGPSM=+Y "RTN","DGPTFM2",8,0) I '$P(Y,U,3) S DIR("A")="Do you want to edit this CPT RECORD DATE/TIME?",DIR(0)="Y",DIR("B")="YES" D ^DIR G ^DGPTFM:'Y!$D(DIRUT) "RTN","DGPTFM2",9,0) D MOB "RTN","DGPTFM2",10,0) I $P(DGZPRF,U,3) F I=1:1:$P(DGZPRF,U,3) S:DGZPRF(I,0)=DGPSM DGZP=I "RTN","DGPTFM2",11,0) K I G:'DGZP ^DGPTFM S X="A,B",DGPSM=0 "RTN","DGPTFM2",12,0) ED G HELP^DGPTUTL1:X'["A"&(X'["B")&(X'["a")&(X'["b") K DA "RTN","DGPTFM2",13,0) S DGJUMP=X,DGPRD=+DGZPRF(DGZP) "RTN","DGPTFM2",14,0) I X["A"!(X["a") D L -^DGPT(PTF) I FLAG D MOB,REQ^DGPTFM3 G EXIT "RTN","DGPTFM2",15,0) .S DA(1)=PTF,DIE="^DGPT("_PTF_",""C"",",(DA,REC)=DGZPRF(DGZP,0) "RTN","DGPTFM2",16,0) .S DR=".01;.02;.03;.05;.09////0",DIC(0)="AELQZ" Q:'$$LOCK "RTN","DGPTFM2",17,0) .D FMDIE S FLAG=$D(Y)>9!$D(DOUT)!'$D(DA) Q:$D(Y)>9!'$D(DA) "RTN","DGPTFM2",18,0) .S DGPRD=+^DGPT(PTF,"C",DGZPRF(DGZP,0),0) Q:+DGZPRF(DGZP)=DGPRD "RTN","DGPTFM2",19,0) .S DGI=0 F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 D Q:$D(Y)>9!'$D(DA) "RTN","DGPTFM2",20,0) ..Q:+^DGCPT(46,DGI,1)'=+DGZPRF(DGZP) Q:$D(^(9)) "RTN","DGPTFM2",21,0) ..S DR=".14////"_DGPRD,(DA,REC)=DGI,DIE="^DGCPT(46," D FMDIE "RTN","DGPTFM2",22,0) ..I $D(Y)>9!'$D(DA) S FLAG=1 "RTN","DGPTFM2",23,0) .S $P(DGZPRF(DGZP),U)=DGPRD "RTN","DGPTFM2",24,0) JUMP I DGJUMP["B"!(DGJUMP["b") S DGI=0 D CL^SDCO21(DFN,DGPRD,"",.SDCLY) D "RTN","DGPTFM2",25,0) .F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 I +^DGCPT(46,DGI,1)=+DGZPRF(DGZP),'$G(^(9)) D I $D(DUOUT) Q:'DGDIAG K DUOUT S DGI=0 "RTN","DGPTFM2",26,0) ..S (DA,REC)=DGI,DR=".01;",DIE="^DGCPT(46," D GETINFO^DGPTFM21 "RTN","DGPTFM2",27,0) .Q:$D(DUOUT) "RTN","DGPTFM2",28,0) .F D D ^DIC S A=0 Q:Y'>0 D SED Q:$D(DUOUT) "RTN","DGPTFM2",29,0) ..S DA=PTF,DIC="^DGCPT(46,",DIC(0)="AELMQZ",DLAYGO=46 "RTN","DGPTFM2",30,0) ..S DIC("S")="D EN6^DGPTFJC I 'DGER" "RTN","DGPTFM2",31,0) I $D(DUOUT),$G(DGDIAG) K DUOUT G JUMP "RTN","DGPTFM2",32,0) I $D(DUOUT),$G(DGJUMP)["A"!($G(DGJUMP)["a") S X=DGJUMP K DUOUT G ED "RTN","DGPTFM2",33,0) K DR,DIE,DIC,DA,DGI,DGJUMP,DGPRD,DLAYGO,XREF "RTN","DGPTFM2",34,0) D REQ^DGPTFM3,MOB H:RFL 2 K RFL "RTN","DGPTFM2",35,0) G ^DGPTFM:'$D(DGZPRF(DGZP,0)),^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(DGZP,0))) "RTN","DGPTFM2",36,0) SET D MOB:'$D(DGZPRF) S:'$D(DGZP) DGZP=1 I $G(DGZPRF(DGZP,0))="" K DGZPRF(DGZP) G NEXP "RTN","DGPTFM2",37,0) WRT G ^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(DGZP,0),0)) S J=DGZP W @IOF,HEAD,?68 "RTN","DGPTFM2",38,0) N DGNUM S Z="<"_DGZP_">" W @DGVI,Z,@DGVO,!! S Y=+DGZPRF(J),Z="A" "RTN","DGPTFM2",39,0) D D^DGPTUTL,Z^DGPTFM5 W ?5,"CPT Record Date/Time: ",Y "RTN","DGPTFM2",40,0) I $P(DGZPRF(J),U,8)'="" W ?55,"Visit Service Category: ",$P(DGZPRF(J),U,8) "RTN","DGPTFM2",41,0) I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " D "RTN","DGPTFM2",42,0) .S L=$P(DGZPRF(J),U,2) D PRV^DGPTFM "RTN","DGPTFM2",43,0) W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV^DGPTFM "RTN","DGPTFM2",44,0) I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U) "RTN","DGPTFM2",45,0) W !! S Z="B" D Z^DGPTFM5 W " Procedures: " "RTN","DGPTFM2",46,0) F K=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K)) I '$D(DGZPRF(J,K,9)) D "RTN","DGPTFM2",47,0) .W ?5 D CPT^DGPTUTL1 W ! Q:$Y>16 "RTN","DGPTFM2",48,0) F I=1:1:(IOSL-$Y-5) W ! "RTN","DGPTFM2",49,0) K I,J,K,L,Z S DGNUM=$S($D(DGZPRF(DGZP+1)):DGZP+1,1:"MAS") "RTN","DGPTFM2",50,0) G 801^DGPTFJC:DGST "RTN","DGPTFM2",51,0) S DIR("A")="Enter to continue, A-B to edit, 'I' to add an 801," "RTN","DGPTFM2",52,0) S DIR("A")=DIR("A")_$C(10,13)_"the number of an 801 screen, ?? to list 801 screens," "RTN","DGPTFM2",53,0) S DIR("A")=DIR("A")_$C(10,13)_"'S' for Send to PCE," "RTN","DGPTFM2",54,0) S DIR("A")=DIR("A")_" '^N' for screen N, or '^' to abort:" "RTN","DGPTFM2",55,0) S DIR("?")="^D HELP^DGPTUTL1" "RTN","DGPTFM2",56,0) S DIR(0)="F^OU",DIR("B")=DGNUM,DIR("??")="^D DISP^DGPTUTL1" D ^DIR "RTN","DGPTFM2",57,0) K DIR G:$D(DIRUT) Q^DGPTF:X="^" "RTN","DGPTFM2",58,0) I X?1"^".E S DGPTSCRN=801 G ^DGPTFJ "RTN","DGPTFM2",59,0) I X="MAS" S DGZP=1 G ^DGPTFM "RTN","DGPTFM2",60,0) G ADD:X="I"!(X="i"),HELP^DGPTUTL1:X["?" "RTN","DGPTFM2",61,0) I X?1N.N,$D(DGZPRF(X)) S DGZP=X G SET "RTN","DGPTFM2",62,0) I X["A"!(X["B")!(X["a")!(X["b") G ED "RTN","DGPTFM2",63,0) I X="S"!(X="s") D PCE G WRT "RTN","DGPTFM2",64,0) D HELP^DGPTUTL1 R !!,"Enter : ",X:DTIME G WRT "RTN","DGPTFM2",65,0) PCE L +^DGPT(PTF):2 "RTN","DGPTFM2",66,0) I '$T W !,"CPT Record is being edited by another user" H 2 Q "RTN","DGPTFM2",67,0) D ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21 "RTN","DGPTFM2",68,0) S RES=$$DATA2PCE^DGAPI1(DFN,PTF,DGZP) "RTN","DGPTFM2",69,0) I RES=1 L -^DGPT(PTF) W !,"PTF Record sent to PCE" H 2 Q "RTN","DGPTFM2",70,0) W @IOF "RTN","DGPTFM2",71,0) ;F I=1:1 Q:'$D(^TMP("DGPAPI",$J,"DIERR",$J,1,"TEXT",I)) W !,^(I) "RTN","DGPTFM2",72,0) W !,"The PTF Record may not have been filed in PCE due to errors." "RTN","DGPTFM2",73,0) W !,"Press return to continue." R X:DTIME "RTN","DGPTFM2",74,0) L -^DGPT(PTF) Q "RTN","DGPTFM2",75,0) NEXP S DGZP=DGZP+1 "RTN","DGPTFM2",76,0) I '$D(DGZPRF(DGZP)) W:DGZP=2 !,"NO PROF. SERVICES TO EDIT." G EXIT "RTN","DGPTFM2",77,0) G SET "RTN","DGPTFM2",78,0) EXIT K DGPSM H 2 S DGZP=1 G ^DGPTFM "RTN","DGPTFM2",79,0) DEL ;DELETE A CPT RECORD "RTN","DGPTFM2",80,0) I '$P(DGZPRF,U,3) G NOPROC "RTN","DGPTFM2",81,0) ASK S DIR("A")="Select 801 record to Delete" "RTN","DGPTFM2",82,0) S DIR(0)="NO^1:"_$P(DGZPRF,U,3),DIR("??")="^D DISP^DGPTUTL1" "RTN","DGPTFM2",83,0) D ^DIR K DIR G ^DGPTFM:$D(DIRUT),^DGPTFM:'Y,^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(Y,0),0)) S DGZP=Y,Y=+^(0) D D^DGPTUTL "RTN","DGPTFM2",84,0) S DIR("A")="Are you sure you want to delete the entire 801 for "_Y "RTN","DGPTFM2",85,0) S DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G ^DGPTFM:'Y,^DGPTFM:'$$LOCK "RTN","DGPTFM2",86,0) S DGI=0 D NOW^%DTC "RTN","DGPTFM2",87,0) F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 D:+^DGCPT(46,DGI,1)=+DGZPRF(DGZP)&'$G(^(9)) "RTN","DGPTFM2",88,0) .S (DA,REC)=DGI,DIE="^DGCPT(46,",DR="1////^S X=%" D FMDIE "RTN","DGPTFM2",89,0) S DR=".09////1",DIE="^DGPT("_PTF_",""C"",",DA=DGZPRF(DGZP,0) "RTN","DGPTFM2",90,0) S DA(1)=PTF D ^DIE L -^DGPT(PTF) "RTN","DGPTFM2",91,0) W !!,"CPT Records....Deleted" H 2 "RTN","DGPTFM2",92,0) K DIK,DA,DGI,DGPROC,DGPSM,DGPNUM,Y D MOB G ^DGPTFM "RTN","DGPTFM2",93,0) NOPROC W !!,*7,"No procedures to delete",! H 3 G ^DGPTFM "RTN","DGPTFM2",94,0) N ;ADD CPT CODES TO CPT RECORD "RTN","DGPTFM2",95,0) I '$P(DGZPRF,U,3) W !!,"There are no 801 records that can be added to.",*7 H 2 G ^DGPTFM "RTN","DGPTFM2",96,0) P1 S DIR("A")="Add to 801 record ",DIR(0)="NO^1:"_$P(DGZPRF,U,3) "RTN","DGPTFM2",97,0) S DIR("??")="^D DISP^DGPTUTL1" "RTN","DGPTFM2",98,0) D ^DIR K DIR G ^DGPTFM:'Y "RTN","DGPTFM2",99,0) S DGZP=Y,DGI=0,DGPRD=+DGZPRF(DGZP) D CL^SDCO21(DFN,DGPRD,"",.SDCLY) "RTN","DGPTFM2",100,0) S DA=PTF,DIC="^DGCPT(46,",DIC(0)="AELQMZ",DLAYGO=46,DIC("S")="D EN6^DGPTFJC I 'DGER" "RTN","DGPTFM2",101,0) D ^DIC K DIC,DLAYGO D:Y>0 SED,MOB,REQ^DGPTFM3 K DGPRD,Y "RTN","DGPTFM2",102,0) D PCE^DGPTFQWK G ^DGPTFM "RTN","DGPTFM2",103,0) DC ;DELETE A CPT PROCEDURE "RTN","DGPTFM2",104,0) I $E($G(ANS),2,99)>0 S DGPZ=+$E(ANS,2,99) G QQ "RTN","DGPTFM2",105,0) S DIR("A")="Select 801 record to Delete a CPT code in" "RTN","DGPTFM2",106,0) S DIR(0)="NO^1:"_$P(DGZPRF,U,3),DIR("??")="^D DISP^DGPTUTL1" "RTN","DGPTFM2",107,0) D ^DIR K DIR G ^DGPTFM:$D(DIRUT),^DGPTFM:'Y,^DGPTFM:'$D(^DGPT(PTF,"C",DGZPRF(Y,0),0)) S DGZP=Y,Y=+^(0) D D^DGPTUTL "RTN","DGPTFM2",108,0) F PS2=1:1 Q:'$D(DGZPRF(DGZP,PS2)) S PS2(PS2)=DGZP_"^"_PS2 "RTN","DGPTFM2",109,0) S PS2=PS2-1 "RTN","DGPTFM2",110,0) QQ S DIR("A")="Select CPT code to Delete <1 - "_PS2_">",DIR(0)="NO^^K:X<1!(X>"_PS2_") X" D ^DIR K DIR G ^DGPTFM:$D(DIRUT),^DGPTFM:'Y "RTN","DGPTFM2",111,0) QQA S A1=Y,DGZP=+PS2(A1),CPT=+DGZPRF(DGZP,$P(PS2(A1),U,2)) "RTN","DGPTFM2",112,0) S DIR("A")="Are you sure you want to delete CPT code '" "RTN","DGPTFM2",113,0) I $D(^ICPT(CPT)) D "RTN","DGPTFM2",114,0) .S N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF)) "RTN","DGPTFM2",115,0) .S N=$S(N>0:$P(N,U,2,99),1:"") "RTN","DGPTFM2",116,0) .S DIR("A")=DIR("A")_$P(N,U)_" "_$P(N,U,2)_"'" "RTN","DGPTFM2",117,0) E S DIR("A")=DIR("A")_CPT_" UNKNOWN" "RTN","DGPTFM2",118,0) S DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G ^DGPTFM:'Y "RTN","DGPTFM2",119,0) G ^DGPTFM:'$$LOCK "RTN","DGPTFM2",120,0) QEL D NOW^%DTC S DA=DGZPRF(DGZP,$P(PS2(A1),U,2),0),DR="1////^S X=%" "RTN","DGPTFM2",121,0) S REC=DGZPRF(DGZP,0) "RTN","DGPTFM2",122,0) S DIE="^DGCPT(46," D FMDIE K A1,DR W !!,"CPT Code....Deleted" "RTN","DGPTFM2",123,0) I '$D(DGZPRF(DGZP,2)) S DR=".09////1",DIE="^DGPT("_PTF_",""C"",",DA=DGZPRF(DGZP,0),DA(1)=PTF D ^DIE "RTN","DGPTFM2",124,0) I $D(DGZPRF(DGZP,2)) D PCE^DGPTFQWK "RTN","DGPTFM2",125,0) L -^DGPT(PTF) W:$X>70 ! D MOB H 2 G ^DGPTFM "RTN","DGPTFM2",126,0) F D MOB S DGZP=$S($E($G(ANS),2,99):+$E($G(ANS),2,99),1:1) G SET "RTN","DGPTFM2",127,0) MOB S (H,I,N)=0 K DGZPRF F M=1:1:6 S:$D(SDCLY(M)) N=N+1 "RTN","DGPTFM2",128,0) F I2=1:1 S H=$O(^DGPT(PTF,"C","B",H)) Q:H'>0 D "RTN","DGPTFM2",129,0) .F S I=$O(^DGPT(PTF,"C","B",H,I)) Q:I'>0 D "RTN","DGPTFM2",130,0) ..S DGZPRF(I2)=^DGPT(PTF,"C",I,0),DGZPRF(I2,0)=I,(K,K1)=0,F=1 D "RTN","DGPTFM2",131,0) ...F S K=$O(^DGCPT(46,"C",PTF,K)),L=N+1\2+3 Q:K'>0 I +DGZPRF(I2)=+$G(^DGCPT(46,K,1)),'$G(^DGCPT(46,K,9)) D "RTN","DGPTFM2",132,0) ....S K1=K1+1,DGZPRF(I2,K1)=^(0),DGZPRF(I2,K1,0)=K,F=0 "RTN","DGPTFM2",133,0) ....F M=2,3,5,6,7,15,16,17,18 S:$P(DGZPRF(I2,K1),U,M) L=L+1 "RTN","DGPTFM2",134,0) ....S DGZPRF(I2,K1,1)=L "RTN","DGPTFM2",135,0) ...I F,$G(DGPSM)'=DGZPRF(I2,0) K DGZPRF(I2) S I2=I2-1 "RTN","DGPTFM2",136,0) S DGZPRF="1^1^"_(I2-1) K F,I,K,K1,N Q "RTN","DGPTFM2",137,0) SED S DR=".14////"_DGPRD_";.16////"_PTF_";",(DA,REC)=+Y,DIE="^DGCPT(46," D GETINFO^DGPTFM21 Q "RTN","DGPTFM2",138,0) FMDIE ;Prompt user for questions and file answers (using DIE) "RTN","DGPTFM2",139,0) D ^DIE Q:$D(Y)>9 S RES=$$DELVFILE^DGAPI1(DFN,PTF,DGZP) K DIE,REC Q "RTN","DGPTFM2",140,0) LOCK() L +^DGPT(PTF):2 I Q 1 "RTN","DGPTFM2",141,0) ERR W !,"CPT Record is being edited by another user" K DIE,REC H 2 Q 0 "RTN","DGPTFM21") 0^4^B15573212 "RTN","DGPTFM21",1,0) DGPTFM21 ;ALB/DWS - MASTER PROFESSIONAL SERVICE ENTER/EDIT(CONT.) ;5/24/05 1:04pm "RTN","DGPTFM21",2,0) ;;5.3;Registration;**635**;Aug 13, 1993 "RTN","DGPTFM21",3,0) GETINFO ;GET PROCEDURE CODE INFORMATION "RTN","DGPTFM21",4,0) N NOKILL,EXITFLAG,DGNIEN "RTN","DGPTFM21",5,0) S NOKILL=1,EXITFLG=0,ERRFLG=0,DGDIAG=0 "RTN","DGPTFM21",6,0) D ICDINFO^DGAPI(DFN,PTF) ;gather all DGN codes for the patient "RTN","DGPTFM21",7,0) D XREF S DIE="^DGCPT(46," "RTN","DGPTFM21",8,0) D SDR,FMDIE^DGPTFM2 ;prompt for CPT Code and modifiers "RTN","DGPTFM21",9,0) I $D(Y)>9 S DUOUT=1 Q "RTN","DGPTFM21",10,0) I $G(ERRFLG)=1 Q ;cannot lock REC in DGCPT - exit "RTN","DGPTFM21",11,0) S DGDIAG=1 "RTN","DGPTFM21",12,0) S DR="" F PIECE=4:1:7,21:1:24 S:PIECE=24 NOKILL=0 D Q:EXITFLG!$D(DUOUT) ;Go thru all existing DGN's in DGCPT file "RTN","DGPTFM21",13,0) . S DIE="^DGCPT(46," D SDR2(PIECE),FMDIE^DGPTFM2 I $D(Y)>9 S DUOUT=1 Q "RTN","DGPTFM21",14,0) . I ('$$CHKDGNS(DA,PIECE))!($D(Y)>9)!($D(DTOUT)) S EXITFLG=1 Q ;Promt w/existing DGN cd if it exists "RTN","DGPTFM21",15,0) . S DR="",SAVDA=DA,DGNIEN=$P(^DGCPT(46,DA,0),U,$S(PIECE<20:PIECE,1:PIECE-6)) Q:DGNIEN="" "RTN","DGPTFM21",16,0) . I '$D(XREF(DGNIEN)) D ;the IEN to be added has not yet been defined in DGICD9, it must be added before proceeding "RTN","DGPTFM21",17,0) . . K DO S DIC="^DGICD9(46.1,",DIC(0)="LMZ",DLAYGO=46,X=DGNIEN "RTN","DGPTFM21",18,0) . . D FILE^DICN Q:$D(DUOUT) I Y<0 S ERRFLG=1 "RTN","DGPTFM21",19,0) . . I 'ERRFLG S XREF(DGNIEN)=+Y ; setup info to build "B" xref in DGICD9 for new entry "RTN","DGPTFM21",20,0) . I ERRFLG S EXITFLG=1 Q ;could not add new DGN ien to DGICD9 - exit loop with error "RTN","DGPTFM21",21,0) . D SCI(DGNIEN):0 S UPDTD=0,(DA,REC)=XREF(DGNIEN) ;determine if any SCI prompts should be done for this DGN "RTN","DGPTFM21",22,0) . K ^TMP("PTF",$J) ;Clean up TMP file to pass info to be filed in 46.1 "RTN","DGPTFM21",23,0) . S DIE="^DGICD9(46.1,",DR="[DG801]" ;SCI flags to be stored in file 46.1 "RTN","DGPTFM21",24,0) . ;prompt for SCI y/n and file in 46.1 "RTN","DGPTFM21",25,0) . I DR'="" D FMDIE^DGPTFM2 S DR="",UPDTD=1 I $D(Y)>9 S DUOUT=1 Q "RTN","DGPTFM21",26,0) . I 'UPDTD D "RTN","DGPTFM21",27,0) . . S ^TMP("PTF",$J,46.1,1)="^"_DGNIEN "RTN","DGPTFM21",28,0) . . S X=$$DATA2PTF^DGAPI(DFN,PTF,DGPRD) ;If there were no SCI's prompts, stuff DGN into file 46.1 "RTN","DGPTFM21",29,0) . S DA=SAVDA "RTN","DGPTFM21",30,0) K DIR,REC "RTN","DGPTFM21",31,0) Q ;GETINFO "RTN","DGPTFM21",32,0) XREF ;create xref for ^TMP global containing DGICD9 info to have access via DGN IEN in local array XREF "RTN","DGPTFM21",33,0) N SEQ,NODE,INFO,IEN "RTN","DGPTFM21",34,0) K XREF "RTN","DGPTFM21",35,0) S SEQ=0 "RTN","DGPTFM21",36,0) F S SEQ=$O(^TMP("PTF",$J,46.1,SEQ)) Q:'SEQ S INFO=^(SEQ),NODE=+INFO,IEN=$P(INFO,U,2),XREF(IEN)=NODE "RTN","DGPTFM21",37,0) Q ;XREF "RTN","DGPTFM21",38,0) SDR ;SET DR ARRAY CPT MODIFIERS 1 AND 2 "RTN","DGPTFM21",39,0) S DR=DR_"S:'$$CODM^ICPTCOD($P(^DGCPT(46,D0,0),U),,,+DGZPRF(DGZP)) Y=""@10"";" "RTN","DGPTFM21",40,0) S DR=DR_".02;S:$P(^DGCPT(46,D0,0),U,2,3)?.""^"" Y=""@10"";.03;@10;.2//1;" "RTN","DGPTFM21",41,0) Q ;Exit SDR "RTN","DGPTFM21",42,0) SDR2(DGN) ;Set up DR variable to prompt for DGN Codes "RTN","DGPTFM21",43,0) S DR=DGN/100_";" "RTN","DGPTFM21",44,0) Q ;Exit SDR2 "RTN","DGPTFM21",45,0) CHKDGNS(D0,DGNPC) ;Check to see if there are any more DGN's to edit in a Professional service instance "RTN","DGPTFM21",46,0) S MORE=1 ; Default - more DGN's to process "RTN","DGPTFM21",47,0) I DGNPC=4 S:$P(^DGCPT(46,D0,0),U,4,7)?."^" MORE=0 "RTN","DGPTFM21",48,0) I DGNPC=5 S:$P(^DGCPT(46,D0,0),U,5,7)?."^" MORE=0 "RTN","DGPTFM21",49,0) I DGNPC=6 S:$P(^DGCPT(46,D0,0),U,6,7)?."^" MORE=0 "RTN","DGPTFM21",50,0) I DGNPC=7 S:$P(^DGCPT(46,D0,0),U,7)_$P(^DGCPT(46,D0,0),U,15,18)?."^" MORE=0 "RTN","DGPTFM21",51,0) I DGNPC=21 S:$P(^DGCPT(46,D0,0),U,15,18)?."^" MORE=0 "RTN","DGPTFM21",52,0) I DGNPC=22 S:$P(^DGCPT(46,D0,0),U,16,18)?."^" MORE=0 "RTN","DGPTFM21",53,0) I DGNPC=23 S:$P(^DGCPT(46,D0,0),U,17,18)?."^" MORE=0 "RTN","DGPTFM21",54,0) I DGNPC=24 S:$P(^DGCPT(46,D0,0),U,18)?."^" MORE=0 "RTN","DGPTFM21",55,0) Q MORE ;exit w/flag "RTN","DGPTFM21",56,0) SCI(IEN) Q:'$D(SDCLY) ;Pass the ien of the DGN code being processed "RTN","DGPTFM21",57,0) N NODE,I,SCINUM "RTN","DGPTFM21",58,0) F I=2,8,3:1:7 D ;Go thru the SCI's "RTN","DGPTFM21",59,0) . S SCINUM=$S(I=2:I+1,((I=3)!(I=4)):I-2,1:I-1) "RTN","DGPTFM21",60,0) . I $G(SDCLY(SCINUM,IEN))=1 Q ;If the SCI has already been asked for the DGN (ien) don't ask again "RTN","DGPTFM21",61,0) . S:I=6 DR=DR_"@30;" "RTN","DGPTFM21",62,0) . I $D(SDCLY(SCINUM)) S DR=DR_(I/100)_";",(DA,D)=$G(XREF(IEN)),SDCLY(SCINUM,IEN)=1 D:I=2&$O(SDCLY(1))!$D(SDCLY(1))!$D(SDCLY(2)) ;add prompt for SCI Y/N "RTN","DGPTFM21",63,0) . . I I<6 S DR=DR_"S:$P(^DGICD9(46.1,DA,0),U,2) Y=""@30"";" "RTN","DGPTFM21",64,0) K I "RTN","DGPTFM21",65,0) Q ;SCI "RTN","DGPTFM3") 0^7^B16699199 "RTN","DGPTFM3",1,0) DGPTFM3 ;ALB/ADL - MASTER CPT RECORD ENTER/EDIT PART 2 ;5/5/05 7:35am "RTN","DGPTFM3",2,0) ;;5.3;Registration;**517,590,594,635**;Aug 13, 1993 "RTN","DGPTFM3",3,0) REQ ;CHECK FOR REQUIRED FIELDS IN CPT RECORDS. RECORDS MISSING ONE OR MORE REQUIRED FIELDS ARE DELETED. "RTN","DGPTFM3",4,0) S RFL=0 G REQQ:'$D(DGZPRF(DGZP,0)) "RTN","DGPTFM3",5,0) I '$P(^DGPT(PTF,"C",DGZPRF(DGZP,0),0),U,3) S DA(1)=PTF,DA=DGPSM,DIK="^DGPT("_PTF_",""C""," D G REQQ "RTN","DGPTFM3",6,0) .D ^DIK K DA W !!,"No CPT record has been filed because no performing provider was specified." S RFL=1 "RTN","DGPTFM3",7,0) S (I,FCPT)=0 D RESEQ(PTF) "RTN","DGPTFM3",8,0) F J=1:1 S I=$O(^DGCPT(46,"C",PTF,I)) Q:'I D:+^DGCPT(46,I,1)=+DGZPRF(DGZP)&'$G(^(9)) "RTN","DGPTFM3",9,0) .I $P(^DGCPT(46,I,0),U,4) S FCPT=1 Q "RTN","DGPTFM3",10,0) .S DA=I,DIK="^DGCPT(46,",CPT=+^DGCPT(46,I,0) D ^DIK "RTN","DGPTFM3",11,0) .W !!,"CPT " S N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF)) W $P(N,U,2)," ",$P(N,U,3)," not filed because no diagnosis 1 was entered." "RTN","DGPTFM3",12,0) .S RFL=1 "RTN","DGPTFM3",13,0) I FCPT K FCPT,I,J,N G REQQ "RTN","DGPTFM3",14,0) S DA(1)=PTF,DA=DGZPRF(DGZP,0),DIK="^DGPT("_PTF_",""C""," "RTN","DGPTFM3",15,0) D ^DIK K DA W !!,"No CPT record has been filed because no CPT codes were filed." S RFL=1 K FCPT,I,J,N "RTN","DGPTFM3",16,0) REQQ ;D RESEQ(PTF) "RTN","DGPTFM3",17,0) Q ;REQ "RTN","DGPTFM3",18,0) RESEQ(PTF) ;A subroutine to check if a DGN in the DGCPT global has been deleted and the other DGN's need "RTN","DGPTFM3",19,0) ;to be moved down in sequence to fill the "gap" in the global "RTN","DGPTFM3",20,0) N REC,CPTINFO,DGNARAY "RTN","DGPTFM3",21,0) S REC=0 "RTN","DGPTFM3",22,0) F S REC=$O(^DGCPT(46,"C",PTF,REC)) Q:REC="" K DGNARAY S CPTINFO=^DGCPT(46,REC,0) D "RTN","DGPTFM3",23,0) . F J=4:1:7,15:1:18 S DGNARAY(J)=$P(CPTINFO,U,J) "RTN","DGPTFM3",24,0) . I $$CHKGAP(.DGNARAY) D RESEQDGN(.CPTINFO,.DGNARAY) S ^DGCPT(46,REC,0)=CPTINFO "RTN","DGPTFM3",25,0) Q ;RESEQ "RTN","DGPTFM3",26,0) CHKGAP(DGNARAY) ;Function call to determine if an inside DGN code has been deleted "RTN","DGPTFM3",27,0) ;Back up in the DGNARAY array until a non-null DGN ien is found, then continuing backwards, "RTN","DGPTFM3",28,0) ;if a null ien is located, that means that an "inside" DGN was deleted "RTN","DGPTFM3",29,0) S SEQ=999,END=1,MISSING=0 "RTN","DGPTFM3",30,0) F S SEQ=$O(DGNARAY(SEQ),-1) Q:SEQ=""!MISSING D "RTN","DGPTFM3",31,0) . I DGNARAY(SEQ)'="" S END=1 Q "RTN","DGPTFM3",32,0) . I DGNARAY(SEQ)="",END=1 S MISSING=1 "RTN","DGPTFM3",33,0) Q MISSING "RTN","DGPTFM3",34,0) ; "RTN","DGPTFM3",35,0) RESEQDGN(CPTINFO,DGNARAY) ;Subroutine to shift down DGN codes to replace any inside DGN's that were deleted by the user "RTN","DGPTFM3",36,0) ; "RTN","DGPTFM3",37,0) S SEQ="" K NOTNULL "RTN","DGPTFM3",38,0) F S SEQ=$O(DGNARAY(SEQ)) Q:SEQ="" I DGNARAY(SEQ)'="" S NOTNULL(SEQ)=DGNARAY(SEQ) "RTN","DGPTFM3",39,0) K DGNARAY S SEQ="" "RTN","DGPTFM3",40,0) F I=4:1:7,15:1:18 S DGNARAY(I)="" "RTN","DGPTFM3",41,0) F I=4:1:7,15:1:18 S SEQ=$O(NOTNULL(SEQ)) Q:SEQ="" S DGNARAY(I)=NOTNULL(SEQ) "RTN","DGPTFM3",42,0) F I=4:1:7,15:1:18 S $P(CPTINFO,U,I)=$G(DGNARAY(I)) "RTN","DGPTFM3",43,0) K NOTNULL "RTN","DGPTFM3",44,0) Q ;RESEQDGN "RTN","DGPTFM3",45,0) PF S PTF=D0,DFN=+^DGPT(D0,0) D MOB^DGPTFM2 S PS2=0,J=+DGZPRF "RTN","DGPTFM3",46,0) G END:'$P(DGZPRF,U,3) "RTN","DGPTFM3",47,0) LOOP S Y=+DGZPRF(J),DGSTRT=$S(+$P(DGZPRF,U,4):$P(DGZPRF,U,4),1:4),DGLST=0 "RTN","DGPTFM3",48,0) D CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY),ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21 ; load SCI info and DGN's for this service date "RTN","DGPTFM3",49,0) D D^DGPTUTL W !,J,"-CPT Capture Date/Time: ",Y W:($P(DGZPRF,U,2)-1!($G(PGBRK))) " (cont.)" "RTN","DGPTFM3",50,0) I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " S L=$P(DGZPRF(J),U,2) D PRV^DGPTFM "RTN","DGPTFM3",51,0) W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV^DGPTFM "RTN","DGPTFM3",52,0) I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U) "RTN","DGPTFM3",53,0) S (L1,PGBRK)=0 "RTN","DGPTFM3",54,0) F K1=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K1)) I '$G(DGZPRF(J,K1,9)) D Q:$Y+$G(DGZPRF(J,K1+1,1))>16!($G(PGBRK)) "RTN","DGPTFM3",55,0) . S PS2=PS2+1,K=K1 W !,?2,PS2," " D CPT^DGPTUTL1 "RTN","DGPTFM3",56,0) . W !,?4 S $P(DS,"-",27)="" W DS," Related Diagnosis ",DS "RTN","DGPTFM3",57,0) . F L1=DGSTRT:1:11 S DGLOC=$S(L1<8:L1,1:L1+7),CD=$P(DGZPRF(J,K1),U,DGLOC) I CD D I $Y+$G(CKSCI)>16 S PGBRK=1 Q "RTN","DGPTFM3",58,0) . . S N=$$ICDDX^ICDCODE(CD,$$GETDATE^ICDGTDRG(PTF)),N=$S(N:$P(N,U,2,99),1:"") "RTN","DGPTFM3",59,0) . . S CD=$P(N,U) W !,?8,CD," ",$P(N,U,3) "RTN","DGPTFM3",60,0) . . D CKSCI^DGPTFM($P(DGZPRF(J,K1),U,DGLOC)) "RTN","DGPTFM3",61,0) . S PS2(PS2)=J_U_K1,CD=1,DGLOC=0,DGSTRT=4 "RTN","DGPTFM3",62,0) I L1'=11,$S(L1<8:$P($G(DGZPRF(J,K1)),U,L1+1,7),1:"")_$P($G(DGZPRF(J,K1)),U,$S(L1<8:15,1:L1+8),18)?."^" S L1=11 "RTN","DGPTFM3",63,0) I L1=11 S $P(DGZPRF,U,1,2)=$S($D(DGZPRF(J,K1+1)):J_U_(K1+1),1:J+1_U_1),$P(DGZPRF,U,4)="",PGBRK=0 "RTN","DGPTFM3",64,0) E S $P(DGZPRF,U,1,2)=J_U_K1,$P(DGZPRF,U,4)=L1+1 "RTN","DGPTFM3",65,0) S J=+DGZPRF I $D(DGZPRF(J)) D HEAD^DGPTFMO G LOOP "RTN","DGPTFM3",66,0) END I $E(IOST)="C" W ! S DIR(0)="E" D ^DIR K DIR "RTN","DGPTFM3",67,0) K I,K1,L1,CD,N Q "RTN","DGPTFQWK") 0^8^B17529486 "RTN","DGPTFQWK",1,0) DGPTFQWK ;ALB/AS - QUICK/LOAD PTF DATA ;7/21/05 2:44pm "RTN","DGPTFQWK",2,0) ;;5.3;Registration;**517,594,635**;Aug 13, 1993 "RTN","DGPTFQWK",3,0) ; "RTN","DGPTFQWK",4,0) S (DGPTF,DA)=PTF,DIE="^DGPT(",DR="[DGQWK"_$S('DGPTFE:"]",1:"F]") W !,"* editing 101 & 701 transactions" D ^DIE S DR="[DG701]" D ^DIE W !,"* editing 501 transactions" "RTN","DGPTFQWK",5,0) F DGM=0:0 D S501 Q:Y'>0 K DA S (DGPTF,DA)=PTF S DGMOV=+Y,DGJUMP=$S('DGPTFE:"",1:"1-2"),DR=$S('DGPTFE:"[DG501]",1:"[DG501F]"),DIE="^DGPT(" D ^DIE,CHK501^DGPTSCAN K DGMOV "RTN","DGPTFQWK",6,0) K DIC,DA,DR,DIE "RTN","DGPTFQWK",7,0) W !,"* editing 401 transactions" "RTN","DGPTFQWK",8,0) F DGM=0:0 D S401 Q:Y'>0 K DA S DGSUR=+Y,DGJUMP="1-2",DR="[DG401]",DIE="^DGPT(",(DA,DGPTF)=PTF D ^DIE,CHK401^DGPTSCAN K DGSUR "RTN","DGPTFQWK",9,0) I '$P(^DGPT(PTF,0),U,4) W !,"* editing 801 transactions" D S801 "RTN","DGPTFQWK",10,0) W !,"* editing 601 transactions" S DR="60",DR(2,45.05)=".01;2;S:'X Y=4;3;4:8",DIE="^DGPT(",DA=PTF D ^DIE "RTN","DGPTFQWK",11,0) I '$P(^DGPT(PTF,0),"^",4)&('DGST) W !," Updating TRANSFER DRGs" S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO "RTN","DGPTFQWK",12,0) K DGM,DA,DGMOVENO,DIC,DIE,DR,Y,DGPTF,DGJUMP Q "RTN","DGPTFQWK",13,0) S501 ;-- set up 501 "RTN","DGPTFQWK",14,0) S DA(1)=PTF,DIC("A")="Select 501 MOVEMENT NUMBER: ",DIC(0)="AEQ",DIC="^DGPT("_PTF_",""M""," S:'$D(^DGPT(PTF,"M",0)) ^(0)="^45.02AI^^" D ^DIC "RTN","DGPTFQWK",15,0) K DA,DIC "RTN","DGPTFQWK",16,0) Q "RTN","DGPTFQWK",17,0) ; "RTN","DGPTFQWK",18,0) S401 ;-- set up 401 "RTN","DGPTFQWK",19,0) S DA(1)=PTF,DIC("A")="Select 401 SURGERY DATE: ",DIC(0)="AEQL",DIC="^DGPT("_PTF_",""S""," S:'$D(^DGPT(PTF,"S",0)) ^(0)="^45.01DA^^" D ^DIC "RTN","DGPTFQWK",20,0) K DA,DIC "RTN","DGPTFQWK",21,0) Q "RTN","DGPTFQWK",22,0) ; "RTN","DGPTFQWK",23,0) S801 ;-- set up 801 "RTN","DGPTFQWK",24,0) F D D REQ:$D(PSIEN) Q:$G(RFL)=1!(Y<0) D PCE "RTN","DGPTFQWK",25,0) .S DIC("A")="Select 801 CPT DATE/TIME: " "RTN","DGPTFQWK",26,0) .S DA(1)=PTF,DIC(0)="AEQLZ",DIC="^DGPT("_PTF_",""C"",",DLAYGO=45 "RTN","DGPTFQWK",27,0) .S:'$D(^DGPT(PTF,"C",0)) ^(0)="^45.06^^" D ^DIC "RTN","DGPTFQWK",28,0) .K DA,DIC,PSIEN Q:Y'>0 S DGPRD=+Y(0),DGPSM=+Y D MOB^DGPTFM2 I $P(DGZPRF,U,3) F I=1:1:$P(DGZPRF,U,3) S:DGZPRF(I,0)=DGPSM DGZP=I "RTN","DGPTFQWK",29,0) .S (DA(1),REC)=PTF,DIE="^DGPT("_PTF_",""C"",",(DA,PSIEN)=DGZPRF(DGZP,0),DR=".02;.03;.05" D FMDIE I $D(Y)>9!$D(DTOUT) S Y=-1 Q "RTN","DGPTFQWK",30,0) .S DGI=0,DR=".01;" D CL^SDCO21(DFN,DGPRD,"",.SDCLY) D S Y=1 "RTN","DGPTFQWK",31,0) ..F S DGI=$O(^DGCPT(46,"C",PTF,DGI)) Q:DGI'>0 I +^DGCPT(46,DGI,1)=+DGZPRF(DGZP)&'$D(^(9)) S (DA,REC)=DGI,DR=".01;",DIE="^DGCPT(46," D GETINFO^DGPTFM21 "RTN","DGPTFQWK",32,0) ..F S DA=PTF,DIC="^DGCPT(46,",DIC(0)="AELQMZ",DLAYGO=46,DIC("S")="D EN6^DGPTFJC I 'DGER" D ^DIC K DIC Q:Y'>0 D SED^DGPTFM2 "RTN","DGPTFQWK",33,0) ..S Y=1 "RTN","DGPTFQWK",34,0) K DR,DIE,DIC,DA,DGI,DGJUMP,DGPRD,DLAYGO,RFL Q "RTN","DGPTFQWK",35,0) REQ ;CHECK FOR REQUIRED FIELDS IN CPT RECORDS. RECORDS MISSING ONE OR MORE REQUIRED FIELDS ARE DELETED. "RTN","DGPTFQWK",36,0) S RFL=0 I '$P(^DGPT(PTF,"C",PSIEN,0),U,3) S DA(1)=PTF,DA=DGPSM,DIK="^DGPT("_PTF_",""C""," D G REQQ "RTN","DGPTFQWK",37,0) .D ^DIK K DA W !!,"No CPT records have been filed because no performing provider was specified." S RFL=1 "RTN","DGPTFQWK",38,0) S (I,FCPT)=0 D RESEQ^DGPTFM3(PTF) "RTN","DGPTFQWK",39,0) F J=1:1 S I=$O(^DGCPT(46,"C",PTF,I)) Q:'I D:+^DGCPT(46,I,1)=DGPRD&'$G(^(9)) "RTN","DGPTFQWK",40,0) .I $P(^DGCPT(46,I,0),U,4) S FCPT=1 Q "RTN","DGPTFQWK",41,0) .S DA=I,DIK="^DGCPT(46,",CPT=+^DGCPT(46,I,0) D ^DIK "RTN","DGPTFQWK",42,0) .W !!,"CPT " S N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF)) W $P(N,U,2)," ",$P(N,U,3)," not filed because no diagnosis 1 was entered." "RTN","DGPTFQWK",43,0) .S RFL=2 "RTN","DGPTFQWK",44,0) I FCPT K FCPT,I,J,N G REQQ "RTN","DGPTFQWK",45,0) S DA(1)=PTF,DA=PSIEN,DIK="^DGPT("_PTF_",""C""," "RTN","DGPTFQWK",46,0) D ^DIK K DA W !!,"No CPT records have been filed because no CPT codes were filed." S RFL=1 K FCPT,I,J,N "RTN","DGPTFQWK",47,0) REQQ ;D RESEQ^DGPTFM3(PTF) "RTN","DGPTFQWK",48,0) Q "RTN","DGPTFQWK",49,0) SED S DR=".14////"_DGPRD_";.16////"_PTF_";",DA=+Y,DIE="^DGCPT(46," "RTN","DGPTFQWK",50,0) S REC=PTF D SDR^DGPTFM21,FMDIE Q "RTN","DGPTFQWK",51,0) PCE S DIR("A")="Send record to PCE? ",DIR(0)="S^Y:YES;N:NO",DIR("B")="NO" "RTN","DGPTFQWK",52,0) D ^DIR K DIR Q:Y="N"!$D(DIRUT) "RTN","DGPTFQWK",53,0) D MOB^DGPTFM2 S RES=$$DATA2PCE^DGAPI1(DFN,PTF,DGZP) "RTN","DGPTFQWK",54,0) I RES=1 L -^DGPT(PTF) W !,"PTF Record sent to PCE" H 2 Q "RTN","DGPTFQWK",55,0) W @IOF "RTN","DGPTFQWK",56,0) ;F I=1:1 Q:'$D(^TMP("DGPAPI",$J,"DIERR",$J,1,"TEXT",I)) W !,^(I) "RTN","DGPTFQWK",57,0) W !,"The PTF Record may not have been filed in PCE due to errors." "RTN","DGPTFQWK",58,0) W !,"Press return to continue." R X:DTIME "RTN","DGPTFQWK",59,0) L -^DGPT(PTF) Q "RTN","DGPTFQWK",60,0) FMDIE L +^DGPT(45,REC):2 "RTN","DGPTFQWK",61,0) I D ^DIE S RES=$$DELVFILE^DGAPI1(DFN,PTF,DGZP) L -^DGPT(45,REC) Q "RTN","DGPTFQWK",62,0) ERR W !,"CPT record is being edited by another user" K DIE,REC S ERRFKG=1 H 2 Q "RTN","DGPTFREL") 0^5^B9388045 "RTN","DGPTFREL",1,0) DGPTFREL ;ALB/JDS - DATA RELEASE ;1/25/05 12:22pm "RTN","DGPTFREL",2,0) ;;5.3;Registration;**635**;Aug 13, 1993 "RTN","DGPTFREL",3,0) ; "RTN","DGPTFREL",4,0) D LO^DGUTL "RTN","DGPTFREL",5,0) ASK L ^DGP(45.83):3 I '$T W !,"Cannot release while transmitting" Q "RTN","DGPTFREL",6,0) L W !! K DIC I '$D(DGRTY) S Y=1 D RTY^DGPTUTL "RTN","DGPTFREL",7,0) S DIC("A")="Release "_$P(DGRTY0,U)_" Record: ",DIC="^DGP(45.84,",DIC(0)="EQMZA" "RTN","DGPTFREL",8,0) S DIC("S")="I '$D(^DGP(45.83,""C"",+Y)),$D(^DGPT(+Y,0)),$P(^(0),U,11)="_DGRTY "RTN","DGPTFREL",9,0) D ^DIC K DIC G Q:Y'>0 S (DA,DGPTIFN,PTF)=+Y "RTN","DGPTFREL",10,0) ; "RTN","DGPTFREL",11,0) EN ; -- entry point "RTN","DGPTFREL",12,0) S DGREL=^DGP(45.84,DGPTIFN,0),DGPTF=^DGPT(DGPTIFN,0),DFN=+DGPTF,DGPT=^DPT(DFN,0),Y=$P(DGREL,U,2) D D^DGPTUTL "RTN","DGPTFREL",13,0) REL ; "RTN","DGPTFREL",14,0) W !!,"Release ",$P(DGRTY0,U)," record #",DGPTIFN," for:",!?5,$P(DGPT,U,1)," - ",$P(DGPT,U,9)," Closed ",Y S %=2 D YN^DICN "RTN","DGPTFREL",15,0) I '% W !!,"Enter 'Y' if this is the ",$P(DGRTY0,U)," record you wish to release for transmission",!,"to Austin, 'N' or if not.",! G REL "RTN","DGPTFREL",16,0) G Q:%'=1 "RTN","DGPTFREL",17,0) I '$D(^DGP(45.83,DT,0)) S (DINUM,X)=DT,DIC="^DGP(45.83,",DIC(0)="L" K DD,DO D FILE^DICN K DINUM,DIC I Y=-1 W !,*7,"Cannot continue without proper FileMan access. Please see your supervisor." G Q "RTN","DGPTFREL",18,0) L +^DGPT(45,DGPTIFN):2 "RTN","DGPTFREL",19,0) I '$T W !,"Patient is being edited by another user" H 2 G Q "RTN","DGPTFREL",20,0) I '($D(^DGP(45.83,DT,"P",0))#2) S ^DGP(45.83,DT,"P",0)="^45.831PA^0^0" "RTN","DGPTFREL",21,0) I $P(^DGP(45.83,DT,0),U,2) S DA=DT,DIE="^DGP(45.83,",DR="1///@" D ^DIE K DIE "RTN","DGPTFREL",22,0) ;S DA=DGPTIFN,DA(1)=DT,DR=".01///"_DGPTIFN,DP=45.831,DIE="^DGP(45.83,"_DT_",""P""," D ^DIE ; old code left for reference "RTN","DGPTFREL",23,0) S (DINUM,X)=DGPTIFN,DIC(0)="L",DA(1)=DT,DIC="^DGP(45.83,"_DT_",""P""," D FILE^DICN K DINUM,DIC,DA "RTN","DGPTFREL",24,0) S DA=DGPTIFN,DIE="^DGP(45.84,",DR="4////"_DT_";5////"_DUZ D ^DIE "RTN","DGPTFREL",25,0) D MOB^DGPTFM2,ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21 "RTN","DGPTFREL",26,0) S DR=".07////1" "RTN","DGPTFREL",27,0) F DGZP=1:1 Q:'$D(DGZPRF(DGZP)) D "RTN","DGPTFREL",28,0) .I '$P(DGZPRF(DGZP),U,7),$$DATA2PCE^DGAPI1(DFN,DGPTIFN,DGZP) D ERR:RES<-1,^DIE:RES>-2 "RTN","DGPTFREL",29,0) W !!,"****** ",$P(DGRTY0,U)," RECORD RELEASED ******",! "RTN","DGPTFREL",30,0) L -^DGPT(45,DGPTIFN) D HANG^DGPTUTL "RTN","DGPTFREL",31,0) I DGRTY=1 D ^A1B2MAIN "RTN","DGPTFREL",32,0) I $D(DRGCAL)!$D(DGPTFLE) G CEN "RTN","DGPTFREL",33,0) G ASK "RTN","DGPTFREL",34,0) ; "RTN","DGPTFREL",35,0) CEN ; -- does census also need to be released if releasing PTF in Load/Edit "RTN","DGPTFREL",36,0) I $D(DGPTFLE),DGRTY=1,$D(DGCST),DGCST=1,$D(DGCI) W !!,*7,"Census Record #",DGCI," also needs to be 'released'." S DGPTIFN=DGCI,Y=2 D RTY^DGPTUTL G EN "RTN","DGPTFREL",37,0) ; "RTN","DGPTFREL",38,0) Q K DGRTY,DGRTY0,DGPTIFN,DGPTFLE,DGREL,DGPTF,DFN,DGPT,A,DIE,DIC,DA,Y,%,X,DR,DP "RTN","DGPTFREL",39,0) D Q1^DGPTF Q "RTN","DGPTFREL",40,0) ERR W @IOF "RTN","DGPTFREL",41,0) F I=1:1 Q:'$D(^TMP("DGPAPI",$J,"DIERR",$J,1,"TEXT",I)) W !,^(I) "RTN","DGPTFREL",42,0) W !,"Press return to continue." R X:DTIME Q "RTN","DGPTFREL",43,0) ; "RTN","DGPTOPCE") 0^9^B1042901 "RTN","DGPTOPCE",1,0) DGPTOPCE ;ALB/DWS - PRINT 801 NOT SENT TO PCE REPORT ;5/24/05 1:04pm "RTN","DGPTOPCE",2,0) ;;5.3;Registration;**635**;Aug 13, 1993 "RTN","DGPTOPCE",3,0) N DIR,DIC,BY,FR,TO,L,DIS,Y,DGST,DGEND "RTN","DGPTOPCE",4,0) S DIR(0)="D^:DT",DIR("A")="Select Start Date",DIR("B")="T-30" D ^DIR "RTN","DGPTOPCE",5,0) K DIR "RTN","DGPTOPCE",6,0) I '$D(DIRUT),Y D "RTN","DGPTOPCE",7,0) .S DGST=Y,DIR(0)="D^:DT",DIR("A")="Select End Date",DIR("B")="T" "RTN","DGPTOPCE",8,0) .W " (",Y(0),")" D ^DIR K DIR "RTN","DGPTOPCE",9,0) .I '$D(DIRUT),Y D "RTN","DGPTOPCE",10,0) ..W " (",Y(0),")" S DGEND=Y,DIC="^DGPT(",FLDS="[801notsenttopce]" "RTN","DGPTOPCE",11,0) ..S BY="[801FIND]",FR(0,1)=DGST,TO(0,1)=DGEND+1 D NOW^%DTC "RTN","DGPTOPCE",12,0) ..S Y=DGST D DD^%DT S DGST=Y,Y=DGEND D DD^%DT S DGEND=Y "RTN","DGPTOPCE",13,0) ..S DHD="[801HEADER]" "RTN","DGPTOPCE",14,0) ..D EN1^DIP "RTN","DGPTOPCE",15,0) Q "RTN","DGPTUTL1") 0^6^B29888402 "RTN","DGPTUTL1",1,0) DGPTUTL1 ;ALB/MJK - PTF Utility ;2/1/05 2:20pm "RTN","DGPTUTL1",2,0) ;;5.3;Registration;**33,45,54,517,635**;Aug 13, 1993 "RTN","DGPTUTL1",3,0) ; "RTN","DGPTUTL1",4,0) FLAG ; -- select PTF rec to update xmit flags "RTN","DGPTUTL1",5,0) S DGMAX=25 "RTN","DGPTUTL1",6,0) W ! S DIC="^DGPT(",DIC(0)="AEMQ",DIC("S")="I '$P(^(0),U,6),$P(^(0),U,11)=1 D CHK^DGPTUTL1 I $D(DGMTY)>9" "RTN","DGPTUTL1",7,0) D ^DIC K DIC G FLAGQ:+Y<0 S (Y,PTF)=+Y D CHK "RTN","DGPTUTL1",8,0) F DGMTY=501,535 I $D(DGMTY(DGMTY)) D UP Q:$D(DGOUT) "RTN","DGPTUTL1",9,0) FLAGQ K DGMAX,DGT,DGADM,DGX,DGA1,DGA,DGMTY,C,DGOUT Q "RTN","DGPTUTL1",10,0) ; "RTN","DGPTUTL1",11,0) UP ; -- select mvt and update xmit flag "RTN","DGPTUTL1",12,0) I DGMTY=501 S DIC="^DGPT("_PTF_",""M"",",DIC("S")="I Y'=1,'$D(^(""P""))" "RTN","DGPTUTL1",13,0) I DGMTY=535 S DIC="^DGPT("_PTF_",535,",DIC("S")="I Y'=1" "RTN","DGPTUTL1",14,0) W ! S DIC(0)="AEMQ" D ^DIC S DIE=DIC K DIC "RTN","DGPTUTL1",15,0) K DGOUT I X["^" S DGOUT="" "RTN","DGPTUTL1",16,0) I +Y<0 G UPQ "RTN","DGPTUTL1",17,0) S DA=+Y,DR=17 D ^DIE K DE,DQ G UP "RTN","DGPTUTL1",18,0) UPQ K DIE,DR Q "RTN","DGPTUTL1",19,0) ; "RTN","DGPTUTL1",20,0) CHK ; "RTN","DGPTUTL1",21,0) N T1,T2,C K DGMTY S T1=0,T2=9999999 "RTN","DGPTUTL1",22,0) F DGMTY=501,535 D 501^DGPTFVC2:DGMTY=501,535^DGPTFVC2:DGMTY=535 S:C>DGMAX DGMTY(DGMTY)="" "RTN","DGPTUTL1",23,0) Q "RTN","DGPTUTL1",24,0) ; "RTN","DGPTUTL1",25,0) INCOME ;-- load ptf income information "RTN","DGPTUTL1",26,0) ; Use discharge date if available; else use current date/time "RTN","DGPTUTL1",27,0) D NOW^%DTC "RTN","DGPTUTL1",28,0) S X=$S($D(^DGPT(PTF,70)):+^(70),1:%),DGX=$S($D(^DGPT(PTF,101)):^(101),1:"") "RTN","DGPTUTL1",29,0) D INC "RTN","DGPTUTL1",30,0) G INQ:Y=$P(DGX,U,7) "RTN","DGPTUTL1",31,0) S DIE="^DGPT(",DA=PTF,DR="101.07////"_Y "RTN","DGPTUTL1",32,0) D ^DIE "RTN","DGPTUTL1",33,0) INQ ; "RTN","DGPTUTL1",34,0) K DGX,DGINCM,DIE,DA,DR,DGI,DG30,DG362,DGT,% "RTN","DGPTUTL1",35,0) Q "RTN","DGPTUTL1",36,0) ; "RTN","DGPTUTL1",37,0) INC ;-- load income information Input:X date,Output:Y-income "RTN","DGPTUTL1",38,0) N DGINCM,DGI,DG30,DG362,DGT,DGX "RTN","DGPTUTL1",39,0) I '$D(X) S Y="" G INCQ "RTN","DGPTUTL1",40,0) S Y=+$P($$INCOME^VAFMON(DFN,X),".") "RTN","DGPTUTL1",41,0) I Y<0 S Y=0 "RTN","DGPTUTL1",42,0) INCQ Q "RTN","DGPTUTL1",43,0) ; "RTN","DGPTUTL1",44,0) CHQUES ;-- This function will deterime if the patient has any of the following "RTN","DGPTUTL1",45,0) ; indicated : AO, IR and EC. If so the array DGEXQ will contain "RTN","DGPTUTL1",46,0) ; DGEXQ(1)="" - AO "RTN","DGPTUTL1",47,0) ; DGEXQ(2)="" - IR "RTN","DGPTUTL1",48,0) ; DGEXQ(3)="" - EC "RTN","DGPTUTL1",49,0) ; Otherwise they will be undefined. "RTN","DGPTUTL1",50,0) K DGEXQ "RTN","DGPTUTL1",51,0) S DGEXQ(1)="",DGEXQ(2)="",DGEXQ(3)="" "RTN","DGPTUTL1",52,0) Q "RTN","DGPTUTL1",53,0) ; "RTN","DGPTUTL1",54,0) SETTRAN ;-- set transmission if error DGOUT=1, will return XMZ "RTN","DGPTUTL1",55,0) K DGXMZ "RTN","DGPTUTL1",56,0) S DGOUTX=0 "RTN","DGPTUTL1",57,0) S Y=$S($P(DGD,".",2)=99:DGSD,1:DGD) X ^DD("DD") "RTN","DGPTUTL1",58,0) S XMSUB=Y_" "_$P(DGRTY0,U)_" TRANSMISSION ",XMDUZ=.5 "RTN","DGPTUTL1",59,0) D GET^XMA2 "RTN","DGPTUTL1",60,0) I $D(XMZ),XMZ>0 S DGXMZ=XMZ K XMZ G SETQ "RTN","DGPTUTL1",61,0) W !!,"*** ERROR *** Unable to create Mail Message #... Try again later." "RTN","DGPTUTL1",62,0) S DGOUTX=1 "RTN","DGPTUTL1",63,0) SETQ ; "RTN","DGPTUTL1",64,0) Q "RTN","DGPTUTL1",65,0) ; "RTN","DGPTUTL1",66,0) KVAR ; -- clean up for l/e "RTN","DGPTUTL1",67,0) K DA,DFN,A,B,I,ANS,DIE,DR,%,%DT,DGPR,DGREL,DGST,DIC,HEAD,J,K,L,M,MT,NU,PTF,DGPTFE,Y,DGZM0,DGZS0,DOB,L1,PT,SEX,AGE,CC,DAM,DOB,DXLS,EXP,NOR,NO,DRG,DRGCAL,DGZSUR,S1,SUR,M1,MOV,P,P1 "RTN","DGPTUTL1",68,0) K DGDX,DGER,DGI,DGINFO,DGLOS,DGNXD,DGP,DGPAS,DGPSV,DGTLOS,DGTY,DIS2,DGJUMP,DGPRD,DGPC,DGDRGNM,DGMOVM,DR,DGQWK,ST1,DGX,DQ,TY,DGRTY,DGRTY0,DGPTFMT,DG,DGA1,DGDC,DGNEXT,RC,DP,POP,DGICD0,DGPROCD,DGPROCI,DGPROCM,DGVAR,DGAD "RTN","DGPTUTL1",69,0) K TAC,TRS,SD,PD,MDC,NDR,NSD,OR,ORG,T,DGZDIAG,DGZPRO,DGZSER,J1,I1,L2,L3,L4,L5,L6,PM,DGFC,S,M2,PROC,SU,ST,NL,DGDD,SD1,D,DFN,DFN1,DFN2,D0,P2,S2,X,DGNUM,DGN,DGERR,DGVI,DGVO,Z,Z1,DGZ,DGADM,DGNODE,^UTILITY($J),DGCFL "RTN","DGPTUTL1",70,0) K DGPM2X,DGPMDA,DGPMDCD,DGPMVI,DGAMY,VAERR,VAIP,DGPTSCRN,DGREC,DGHOLD,DG300,DG300A,DG300B,DG701,DGBPC,DGPTIT,DGMOV,DGSUR "RTN","DGPTUTL1",71,0) K M3,DGLAST,DGMVT "RTN","DGPTUTL1",72,0) Q "RTN","DGPTUTL1",73,0) ; "RTN","DGPTUTL1",74,0) ELIG ; shows eligibility and disabilities "RTN","DGPTUTL1",75,0) D ELIG^VADPT W #,!,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") "RTN","DGPTUTL1",76,0) W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1 "RTN","DGPTUTL1",77,0) .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2) "RTN","DGPTUTL1",78,0) .W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")+$X>80 !,?15 "RTN","DGPTUTL1",79,0) .W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), " "RTN","DGPTUTL1",80,0) .I $Y>22 W !,"PRESS RETURN TO CONTINUE:" R X:DTIME W # "RTN","DGPTUTL1",81,0) Q "RTN","DGPTUTL1",82,0) DATE ;EDIT CPT DATE/TIME TO BE AFTER ADMISSION DATE BUT BEFORE DISCHARGE "RTN","DGPTUTL1",83,0) I X<$P(^DGPT(DA(1),0),U,2) W !,"Not before admission" K X Q "RTN","DGPTUTL1",84,0) I $G(^(70)),X>^(70) W !,"Not after discharge" K X Q "RTN","DGPTUTL1",85,0) S I=0 F S I=$O(^DGPT(PTF,"C",I)) Q:I'>0 I X=+^(I,0) W !,"Cannot change to existing CPT date/time entry" K X Q "RTN","DGPTUTL1",86,0) Q "RTN","DGPTUTL1",87,0) SETABX ;SET AB CROSSREFERENCE IN FILE 45 "RTN","DGPTUTL1",88,0) G KILLABX:$P($G(^DGPT(DA(1),"C",DA,0)),U,7) "RTN","DGPTUTL1",89,0) N BOOL S (DGCPT,BOOL)=0 "RTN","DGPTUTL1",90,0) F S DGCPT=$O(^DGCPT(46,"C",DA(1),DGCPT)) Q:'DGCPT D Q:BOOL "RTN","DGPTUTL1",91,0) .S BOOL='$G(^DGCPT(46,DGCPT,9)) "RTN","DGPTUTL1",92,0) I 'BOOL K ^DGPT("AB",$E(X,1,30),DA(1),DA) "RTN","DGPTUTL1",93,0) S ^DGPT("AB",$E(X,1,30),DA(1),DA)="" Q "RTN","DGPTUTL1",94,0) KILLABX ;KILL AB CROSSREFERENCE IN FILE 45 "RTN","DGPTUTL1",95,0) G SETABX:'$P($G(^DGPT(DA(1),"C",DA,0)),U,7) "RTN","DGPTUTL1",96,0) K ^DGPT("AB",$E(X,1,30),DA(1),DA) Q "RTN","DGPTUTL1",97,0) DISP F I=1:1:$P(DGZPRF,U,3) D "RTN","DGPTUTL1",98,0) .S Y=+DGZPRF(I) D D^DGPTUTL W !,I,?5,Y "RTN","DGPTUTL1",99,0) Q "RTN","DGPTUTL1",100,0) HELP W !,"Enter '^' to stop display and edit of data," "RTN","DGPTUTL1",101,0) W !,"'^N' to jump to screen #N (appears in upper right of screen as" "RTN","DGPTUTL1",102,0) W " ),",!,"a number to jump to that number 801 screen," "RTN","DGPTUTL1",103,0) W " ?? to list the 801 screens," "RTN","DGPTUTL1",104,0) W !," to continue on to next screen or A-B to edit:" "RTN","DGPTUTL1",105,0) W !?10,"A-Professional service information",!,?10,"B-Procedure codes",!,"You may also enter any combination of the above, separated by commas (ex:A,B)",! Q "RTN","DGPTUTL1",106,0) CPT ;DISPLAY CPT CODES AND MODIFIERS "RTN","DGPTUTL1",107,0) S CPT=+DGZPRF(J,K),N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF)),N=$S(N>0:$P(N,U,2,99),1:"") "RTN","DGPTUTL1",108,0) W $P(N,U)," ",$P(N,U,2) "RTN","DGPTUTL1",109,0) F I=1,2 S MOD=$P(DGZPRF(J,K),U,I+1) D MOD:MOD "RTN","DGPTUTL1",110,0) W !,?7,"Quantity: ",$P(DGZPRF(J,K),U,14) K I,MOD,N Q "RTN","DGPTUTL1",111,0) MOD S N=$$MOD^ICPTMOD(MOD,"I",$$GETDATE^ICDGTDRG(PTF)) W !,?7,"CPT Modifier ",I,":",$P(N,U,2)," ",$P(N,U,3) "RTN","DGPTUTL1",112,0) Q "UP",45,45.06,-1) 45^C "UP",45,45.06,0) 45.06 "VER") 8.0^22.0 "^DD",45,45,30,0) CPT RECORD DATE/TIME^45.06D^^C;0 "^DD",45,45,30,"DT") 3041124 "^DD",45,45.06,0) CPT RECORD DATE/TIME SUB-FIELD^^.09^8 "^DD",45,45.06,0,"NM","CPT RECORD DATE/TIME") "^DD",45,45.06,.01,0) CPT RECORD DATE/TIME^RDX^^0;1^S %DT="ETXR",%DT(0)="-NOW" D ^%DT S X=Y K:Y<1 X K %DT D DATE^DGPTUTL1:$D(X) "^DD",45,45.06,.01,1,0) ^.1^^-1 "^DD",45,45.06,.01,1,1,0) 45.06^B "^DD",45,45.06,.01,1,1,1) S ^DGPT(DA(1),"C","B",$E(X,1,30),DA)="" "^DD",45,45.06,.01,1,1,2) K ^DGPT(DA(1),"C","B",$E(X,1,30),DA) "^DD",45,45.06,.01,3) Enter the date and time the professional service was performed. "^DD",45,45.06,.01,"DT") 3050629 "^DD",45,45.06,.02,0) REFERRING OR ORDERING PROVIDER^*P200'X^VA(200,^0;2^S IENS=DA_","_DA(1)_",",CPTDT=$$GET1^DIQ(45.06,IENS,.01,"I") S DIC("S")="I $$ACTIVPRV^PXAPI(Y,CPTDT)" D ^DIC K DIC,IENS,CPTDT S DIC=DIE,X=+Y K:Y<0 X "^DD",45,45.06,.02,3) Enter the name of the provider referring or ordering the service or item "^DD",45,45.06,.02,12) Only Allow Active Providers "^DD",45,45.06,.02,12.1) S DIC("S")="I $$ACTIVPRV^PXAPI(Y,CPTDT)" "^DD",45,45.06,.02,"DT") 3050330 "^DD",45,45.06,.03,0) RENDERING PROVIDER^R*P200'X^VA(200,^0;3^S IENS=DA_","_DA(1)_",",CPTDT=$$GET1^DIQ(45.06,IENS,.01,"I") S DIC("S")="I $$ACTIVPRV^PXAPI(Y,CPTDT)" D ^DIC K DIC,IENS,CPTDT S DIC=DIE,X=+Y K:Y<0 X "^DD",45,45.06,.03,3) Enter the name of the provider performing the procedure. "^DD",45,45.06,.03,12) Only Allow Active Providers. "^DD",45,45.06,.03,12.1) S DIC("S")="I $$ACTIVPRV^PXAPI(Y,CPTDT)" "^DD",45,45.06,.03,"DT") 3050330 "^DD",45,45.06,.05,0) RENDERING LOCATION^R*P44'^SC(^0;5^S DIC("S")="I $P($G(^SC(Y,0)),U,7)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "^DD",45,45.06,.05,3) Enter the location to be used in box 32 on the HCFA 1500. "^DD",45,45.06,.05,12) LOCATION MUST HAVE A STOP CODE "^DD",45,45.06,.05,12.1) S DIC("S")="I $P($G(^SC(Y,0)),U,7)" "^DD",45,45.06,.05,21,0) ^.001^2^2^3050609^^^ "^DD",45,45.06,.05,21,1,0) Enter the location in file 44 where services were furnished. The name of "^DD",45,45.06,.05,21,2,0) the facility and address must be entered in file 4 and pointed to by file 44. "^DD",45,45.06,.05,"DT") 3050609 "^DD",45,45.06,.06,0) VISIT NUMBER^P9000010'^AUPNVSIT(^0;6^Q "^DD",45,45.06,.06,1,0) ^.1 "^DD",45,45.06,.06,1,1,0) 45.06^AC^MUMPS "^DD",45,45.06,.06,1,1,1) D ADD^AUPNVSIT "^DD",45,45.06,.06,1,1,2) D SUB^AUPNVSIT "^DD",45,45.06,.06,1,1,"DT") 3050609 "^DD",45,45.06,.06,3) The VISIT NUMBER is returned from the PXAPI. "^DD",45,45.06,.06,21,0) ^.001^2^2^3041118^^ "^DD",45,45.06,.06,21,1,0) This is a pointer to the Visit File (9000010) in PCE. A visit will be "^DD",45,45.06,.06,21,2,0) generated for each CPT procedure entry. "^DD",45,45.06,.06,"DT") 3050609 "^DD",45,45.06,.07,0) DATA TO PCE FLAG^S^0:NOT SENT;1:SENT TO PCE;^0;7^Q "^DD",45,45.06,.07,3) Indicates that the data in PCE agrees with PTF 801 screen data. "^DD",45,45.06,.07,21,0) ^.001^3^3^3041118^^ "^DD",45,45.06,.07,21,1,0) Set by the PTF system to indiacte if the data in the PTF 810 "^DD",45,45.06,.07,21,2,0) screen has been sent to the PCE system. It is reset to 0 if "^DD",45,45.06,.07,21,3,0) the data is edited, after the data in PCE is deleted. "^DD",45,45.06,.07,"DT") 3050629 "^DD",45,45.06,.09,0) DELETE FLAG^S^0:Valid subfile record;1:All CPT Transactions have been deleted;^0;9^Q "^DD",45,45.06,.09,21,0) ^.001^2^2^3041230^^ "^DD",45,45.06,.09,21,1,0) This field flags deleted records so they do not appear on the "^DD",45,45.06,.09,21,2,0) 801 Screens Not Sent to PCE report. "^DD",45,45.06,.09,23,0) ^^2^2^3041230^ "^DD",45,45.06,.09,23,1,0) This field is set by DGPTFM2 when all the CPT procedure records in a "^DD",45,45.06,.09,23,2,0) subfile entry have been logically deleted. "^DD",45,45.06,.09,"DT") 3050629 "^DD",46,46,.01,0) CPT CODE^R*P81'^ICPT(^0;1^S DIC("S")="D EN6^DGPTFJC I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "^DD",46,46,.01,1,0) ^.1 "^DD",46,46,.01,1,1,0) 46^B "^DD",46,46,.01,1,1,1) S ^DGCPT(46,"B",$E(X,1,30),DA)="" "^DD",46,46,.01,1,1,2) K ^DGCPT(46,"B",$E(X,1,30),DA) "^DD",46,46,.01,1,2,0) ^^TRIGGER^46^.02 "^DD",46,46,.01,1,2,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCPT(46,D0,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X="" S DIH=$G(^DGCPT(46,DIV(0),0)),DIV=X S $P(^(0),U,2)=DIV,DIH=46,DIG=.02 D ^DICR "^DD",46,46,.01,1,2,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCPT(46,D0,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X="" S DIH=$G(^DGCPT(46,DIV(0),0)),DIV=X S $P(^(0),U,2)=DIV,DIH=46,DIG=.02 D ^DICR "^DD",46,46,.01,1,2,"CREATE VALUE") S X="@" "^DD",46,46,.01,1,2,"DELETE VALUE") S X="@" "^DD",46,46,.01,1,2,"DT") 3050603 "^DD",46,46,.01,1,2,"FIELD") CPT MODIFIER 1 "^DD",46,46,.01,1,3,0) ^^TRIGGER^46^.03 "^DD",46,46,.01,1,3,1) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCPT(46,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCPT(46,DIV(0),0)),DIV=X S $P(^(0),U,3)=DIV,DIH=46,DIG=.03 D ^DICR "^DD",46,46,.01,1,3,2) K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCPT(46,D0,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCPT(46,DIV(0),0)),DIV=X S $P(^(0),U,3)=DIV,DIH=46,DIG=.03 D ^DICR "^DD",46,46,.01,1,3,"CREATE VALUE") S X="" "^DD",46,46,.01,1,3,"DELETE VALUE") S X="" "^DD",46,46,.01,1,3,"DT") 3050603 "^DD",46,46,.01,1,3,"FIELD") CPT MODIFIER 2 "^DD",46,46,.01,3) Enter the procedure, services or supplies using CPT or HCPCS "^DD",46,46,.01,12) Allow only active CPT procedures "^DD",46,46,.01,12.1) S DIC("S")="D EN6^DGPTFJC I 'DGER" "^DD",46,46,.01,21,0) ^.001^5^5^3040123^^^^ "^DD",46,46,.01,21,1,0) This is the procedure, services, or supplies used for the patient. It is "^DD",46,46,.01,21,2,0) using the HCFA Common Procedure Coding System (HCPCS) or Common Procedure "^DD",46,46,.01,21,3,0) Terminology (CPT) code. This value appears on the HCFA 1500 in box 24d. "^DD",46,46,.01,21,4,0) the values in this field will be provided to the billing package when "^DD",46,46,.01,21,5,0) the record is closed. "^DD",46,46,.01,"DEL",1,0) W *7,!,"USE DELETE OPTION TO DO LOGICAL DELETE" "^DD",46,46,.01,"DT") 3050603 "^DD",46,46,.02,0) CPT MODIFIER 1^*P81.3'^DIC(81.3,^0;2^S DIC("S")="I $$MODP^ICPTMOD($P(^DGCPT(46,DA,0),U),Y,""I"",DGPRD)>0,$P(^DGCPT(46,DA,0),U,3)'=Y" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "^DD",46,46,.02,3) Indicates that a service or procedure has been altered, but code unchanged. "^DD",46,46,.02,5,1,0) 46^.01^2 "^DD",46,46,.02,12) ALLOW ONLY MODIFIERS VALID FOR THIS CPT "^DD",46,46,.02,12.1) S DIC("S")="I $$MODP^ICPTMOD($P(^DGCPT(46,DA,0),U),Y,""I"",DGPRD)>0,$P(^DGCPT(46,DA,0),U,3)'=Y" "^DD",46,46,.02,21,0) ^.001^2^2^3050331^^^^ "^DD",46,46,.02,21,1,0) Used to indicate that a service or procedure has been altered by some "^DD",46,46,.02,21,2,0) specific circumstance but without changing the definition or code. "^DD",46,46,.02,"DT") 3050331 "^DD",46,46,.03,0) CPT MODIFIER 2^*P81.3'^DIC(81.3,^0;3 ^S DIC("S")="I $$MODP^ICPTMOD($P(^DGCPT(46,DA,0),U),Y,""I"",DGPRD)>0,$P(^DGCPT(46,DA,0),U,2)'=Y" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "^DD",46,46,.03,3) Indicates that a service or procedure has been altered, but code UNCHANGED. "^DD",46,46,.03,5,1,0) 46^.01^3 "^DD",46,46,.03,12) ALLOW ONLY MODIFIERS VALID FOR THIS CPT "^DD",46,46,.03,12.1) S DIC("S")="I $$MODP^ICPTMOD($P(^DGCPT(46,DA,0),U),Y,""I"",DGPRD)>0,$P(^DGCPT(46,DA,0),U,2)'=Y" "^DD",46,46,.03,21,0) ^.001^2^2^3050331^^^^ "^DD",46,46,.03,21,1,0) Used to indicate that a service or procedure has been altered by some "^DD",46,46,.03,21,2,0) specific circumstance but not changed definition or code. "^DD",46,46,.03,"DT") 3050331 "^DD",46,46,.04,0) PRIMARY DIAGNOSIS^*P80^ICD9(^0;4^S DIC("S")="D EN5^DGPTFJC I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X "^DD",46,46,.04,3) The primary diagnosis associated with the procedure performed on the HCFA 1500. "^DD",46,46,.04,12) Allow only active Diagnosis codes. "^DD",46,46,.04,12.1) S DIC("S")="D EN5^DGPTFJC I 'DGER" "^DD",46,46,.04,21,0) ^.001^4^4^3050505^^^^ "^DD",46,46,.04,21,1,0) The diagnosis code most directly related to the procedure code performed for "^DD",46,46,.04,21,2,0) this professional service. This field must be entered for each CPT code "^DD",46,46,.04,21,3,0) entered. It appears in box 21 on the HCFA-1500 and is associated with a "^DD",46,46,.04,21,4,0) procedure in box 24e. "^DD",46,46,.04,"DT") 3050505 "BLD",6310,6) ^SEQ #588 **END** **END**