- DGPTR0 ;MJK/JS/ADL/TJ,HIOFO/FT - PTF TRANSMISSION ;4/21/15 11:28am
- ;;5.3;Registration;**114,247,338,342,510,524,565,678,729,664,850,884**;Aug 13, 1993;Build 31
- ;;ADL;Update for CSV Project;;Mar 27, 2003
- ;
- ; ICDXCODE APIs - #5699
- ; SDCO22 APIs - #1579
- ;
- ; -- setup control data
- ; ssn
- S X=$P(DG10,U,9),Y=$S($E(X,10)="P":"P",1:" ")_$E(X_" ",1,9)
- ; -- adm d/t
- S X=$P($P(DG0,U,2),"."),Y=Y_$E(X,4,5)_$E(X,6,7)_$E(X,2,3)_$E($P($P(DG0,U,2),".",2)_"0000",1,4)
- ; -- facility #
- S L=3,X=DG0,Z=3 D ENTER S Y=Y_$E($P(X,U,5)_" ",1,3)
- S DGHEAD=Y,Y=" "_Y D HEAD^DGPTR1
- ;
- 101 ; -- setup 101 transmission
- ; control data and name
- S Y=$S(T1:"C",1:"N")_"101"_DGHEAD S Y=Y_$$PTFNMFT($P(DG10,U))
- ; source of admission
- S Y=Y_$S($D(^DIC(45.1,+DG101,0)):$J($P(^(0),U,1),2),1:" ")
- ; xfring fac and suffix
- S L=3,X=DG101,Z=5 D ENTER S Y=Y_$E($P(X,U,6)_" ",1,3)
- ; source of payment
- S Y=Y_$S("A0"[$P(DG0,U,5):" ",1:$J($P(DG101,U,3),1))
- ;POW Location
- S Y=Y_$S($P(DG52,U,5)="N":1,$P(DG52,U,5)'="Y":3,$P(DG52,U,6)>0&($P(DG52,U,6)<7):3+$P(DG52,U,6),$P(DG52,U,6)>6&($P(DG52,U,6)<9):$C($P(DG52,U,6)+58),1:" ")
- ;marital status, sex
- S Y=Y_$S($D(^DIC(11,+$P(DG10,U,5),0)):$E(^(0),1),1:" ")_$J($P(DG10,U,2),1)
- ; date of birth
- S DGDOB=$P(DG10,U,3)\1,Y=Y_$E(DGDOB,4,5)_$E(DGDOB,6,7)_(1700+$E(DGDOB,1,3))
- ; period of service
- S DGPOS=$S($D(^DIC(21,+$P(DG32,U,3),0)):$P(^(0),U,3),1:"")
- I $D(^DGPM(+$O(^DGPM("APTF",J,0)),"ODS")),+^("ODS") S DGPOS=6
- ;-- if non vet admitting eligibility make POS 9
- S DGPOS=$$CKPOS^DGPTUTL($P($G(^DGPT(PTF,101)),U,8),DGPOS)
- S X=DGPOS,Z=1,L=2 D ENTER
- ; agent orange
- S G=" " S DGAO=$P(DG321,U,2) S:DGPOS=7 G=$S($P(DG321,U)'="Y":1,DGAO="N":2,DGAO="Y":3,1:4) S:(DGAO="Y")&($P(DG321,U,13)="K") G=5
- ; rad exposure
- S E=" " I "^0^2^4^5^7^8^Z^"[(U_DGPOS_U) S DGNT=$P(DG321,U,12),E=$S($P(DG321,U,3)'="Y":1,DGNT="N":2,DGNT="T":3,DGNT="B":4,1:" ")
- S Y=Y_G_E K DGPOS,G,E
- ; state code
- S X=$S($D(^DIC(5,+$P(DG11,U,5),0)):^(0),1:""),L=2,Z=3 D ENTER0
- ; county code
- S X=$S($D(^DIC(5,+$P(DG11,U,5),1,+$P(DG11,U,7),0)):^(0),1:""),L=3,Z=3 D ENTER0
- ; zip code
- S X=DG11,Z=6,L=5 D ENTER
- ; means test
- S Y=Y_$S($P(DG70,U,26)="Y":"AS",1:$E($P(DG0,U,10)_" ",1,2))
- ; income
- I $L($P(DG101,U,7))>6 S Y=Y_"999999"
- E S X=DG101,Z=7,L=6 D ENTER0
- ;MST
- S X=$$GETSTAT^DGMSTAPI(+DG0) S Y=Y_$S(X<0:"U",1:$P(X,"^",2))
- ;Combat Vet
- S X=$$CVEDT^DGCV(+DG0,$P(DG0,"^",2)) S Y=Y_$S((+X)>0:1,1:0)
- S X=$P(X,"^",2)_" " S Y=Y_$E(X,4,5)_$E(X,6,7)_$E(X,2,3)
- ;Project 112/SHAD
- S X=$$SHAD^SDCO22(+DG0) S Y=Y_$S((+X)>0:1,1:0)
- ;Emergency Response Indicator
- S X=$$EMGRES^DGUTL(+DG0) S Y=Y_$S("^K^"[(U_X_U):X,1:" ")
- ;Country Code
- S X=$$GET1^DIQ(779.004,$P(DG11,U,10)_",",.01),Z=1,L=3 D ENTER
- D FILL^DGPTR2,SAVE
- ;I T1 S Y=$E(Y,1,52)_" "_$E(Y,54,125)
- I T1 S $E(Y,53)=" " ;sets $E(Y,53)=" " if census, but why after it is saved?
- ;
- P401 ; -- setup 401P transaction
- G 401:'$D(^DGPT(J,"401P"))!(T1) S DG41=^("401P"),Y=$S(T1:"C",1:"N")_"401"_DGHEAD_"P"_" "
- N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)
- S DG41=$S($D(^DGPT(J,"401P")):^("401P"),1:"")
- S L=1 F K=1:1:5 S:'$P(DG41,U,K) DG41=$P(DG41,U,1,K-1)_U_$P(DG41,U,K+1,99),K=K-1 S L=L+1 Q:L=5
- F I=1:1:5 S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$P(DG41,U,I),EFFDATE,"I"),Y=Y_$S(+DGPTTMP>0:$J($P($P(DGPTTMP,U,2),".",1),2)_$E($P($P(DGPTTMP,U,2),".",2)_" ",1,3),1:" ")_" "
- K DGPTEDT
- I $E(Y,40)'=" " D FILL^DGPTR2,SAVE
- ;
- 401 ; -- setup 401 transactions
- G 501:'$D(^DGPT(J,"S")) K ^UTILITY($J,"S") S I=0
- SUR ;
- S I=$O(^DGPT(J,"S",I)) G 501:'I S DGSUR=^(I,0),DGAUX=$S($D(^DGPT(J,"S",I,300)):^(300),1:"") G SUR:'DGSUR
- G SUR:DGSUR<T1!(DGSUR>T2) S DGSUD=+^(0)\1,^UTILITY($J,"S",DGSUD)=$S($D(^UTILITY($J,"S",DGSUD)):^(DGSUD),1:0)+1,F=$S(DGSUD<2871000:0,1:1)
- I ^UTILITY($J,"S",DGSUD)>$S(F:3,1:2) D I Y'=1 S DGERR=1 Q
- .W !,"**There are more than ",$S(F:"three",1:"two")," surgeries on the same date**"
- .S DIR(0)="Y",DIR("B")="YES",DIR("A")="OK to continue?" D ^DIR K DIR
- S Y=$S(T1:"C",1:"N")_"401"_DGHEAD_$E(DGSUD,4,5)_$E(DGSUD,6,7)_$E(DGSUD,2,3)_$E($P(+DGSUR,".",2)_"0000",1,4)_$S($D(^DIC(45.3,+$P(DGSUR,U,3),0)):$P(^(0),U,1),1:" ")
- S L=1,X=DGSUR F Z=4:1:7 D ENTER
- N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)
- S L=1 F K=8:1:12 S:'$P(DGSUR,U,K) DGSUR=$P(DGSUR,U,1,K-1)_U_$P(DGSUR,U,K+1,99),K=K-1 S L=L+1 Q:L=5
- F K=8:1:12 S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$P(DGSUR,U,K),EFFDATE,"I"),Y=Y_$S(+DGPTTMP>0:$J($P($P(DGPTTMP,U,2),".",1),2)_$E($P($P(DGPTTMP,U,2),".",2)_" ",1,3),1:" ")_" "
- ;
- ;-- att phy
- S Y=Y_" "
- ;-- additional ptf question
- ;send null, if disch date>inactive date. DG/729
- I +$P($G(^DIC(45.88,1,0)),U,3) S DGAUX=$S((+$G(^DGPT(J,70))<$P(^DIC(45.88,1,0),U,3)):DGAUX,1:"")
- S Y=Y_$E($P(DGAUX,U)_" ")
- K DGAUX
- D FILL^DGPTR2,SAVE G SUR
- 501 G 501^DGPTR2
- Q
- ENTER S Y=Y_$J($P(X,U,Z),L)
- Q
- ENTER0 S Y=Y_$S($P(X,U,Z)]"":$E("000000",$L($P(X,U,Z))+1,L)_$P(X,U,Z),1:$J($P(X,U,Z),L))
- Q
- SAVE ;save segment to MailMan message and ^TMP("AEDIT",$J), if data is valid
- D SAVE^DGPTR2
- Q Q
- DGNAM S X=DGNAM I X?.E.P F I=1:1:$L(X) S Z=$E(X,I) Q:Z="," S:Z?.P&(Z]"") X=$E(X,1,I-1)_$E(X,I+1,$L(X)),I=I-1 Q:X'?.E.P
- I X?.E.L D UP^DGHELP
- S DGNAM=X
- Q
- ;
- PTFNMFT(DG10) ;this function will format the name of the patient for
- ; transmission of the 101 record to Austin. In addition, this
- ; function will be used by OPC so that the format will be consistent
- ; for OPC and PTF.
- ; INPUT : DG10 - .01 field from the patient record.
- ; OUTPUT: name in the format proper format.
- ; A = <12 - characters of last name padded with blanks>
- ; B = <1 - first initial of fist name>
- ; C = <1 - first initial of middle name>
- ; returns :ABC <14 - characters>
- N X,I
- S DGNAM=DG10 D DGNAM
- Q $E($P(DGNAM,",",1)_" ",1,12)_$J($E($P(DGNAM,",",2),1),1)_$J($E($P($P(DGNAM,",",2)," ",2),1),1)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTR0 5934 printed Feb 19, 2025@00:19:23 Page 2
- DGPTR0 ;MJK/JS/ADL/TJ,HIOFO/FT - PTF TRANSMISSION ;4/21/15 11:28am
- +1 ;;5.3;Registration;**114,247,338,342,510,524,565,678,729,664,850,884**;Aug 13, 1993;Build 31
- +2 ;;ADL;Update for CSV Project;;Mar 27, 2003
- +3 ;
- +4 ; ICDXCODE APIs - #5699
- +5 ; SDCO22 APIs - #1579
- +6 ;
- +7 ; -- setup control data
- +8 ; ssn
- +9 SET X=$PIECE(DG10,U,9)
- SET Y=$SELECT($EXTRACT(X,10)="P":"P",1:" ")_$EXTRACT(X_" ",1,9)
- +10 ; -- adm d/t
- +11 SET X=$PIECE($PIECE(DG0,U,2),".")
- SET Y=Y_$EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)_$EXTRACT($PIECE($PIECE(DG0,U,2),".",2)_"0000",1,4)
- +12 ; -- facility #
- +13 SET L=3
- SET X=DG0
- SET Z=3
- DO ENTER
- SET Y=Y_$EXTRACT($PIECE(X,U,5)_" ",1,3)
- +14 SET DGHEAD=Y
- SET Y=" "_Y
- DO HEAD^DGPTR1
- +15 ;
- 101 ; -- setup 101 transmission
- +1 ; control data and name
- +2 SET Y=$SELECT(T1:"C",1:"N")_"101"_DGHEAD
- SET Y=Y_$$PTFNMFT($PIECE(DG10,U))
- +3 ; source of admission
- +4 SET Y=Y_$SELECT($DATA(^DIC(45.1,+DG101,0)):$JUSTIFY($PIECE(^(0),U,1),2),1:" ")
- +5 ; xfring fac and suffix
- +6 SET L=3
- SET X=DG101
- SET Z=5
- DO ENTER
- SET Y=Y_$EXTRACT($PIECE(X,U,6)_" ",1,3)
- +7 ; source of payment
- +8 SET Y=Y_$SELECT("A0"[$PIECE(DG0,U,5):" ",1:$JUSTIFY($PIECE(DG101,U,3),1))
- +9 ;POW Location
- +10 SET Y=Y_$SELECT($PIECE(DG52,U,5)="N":1,$PIECE(DG52,U,5)'="Y":3,$PIECE(DG52,U,6)>0&($PIECE(DG52,U,6)<7):3+$PIECE(DG52,U,6),$PIECE(DG52,U,6)>6&($PIECE(DG52,U,6)<9):$CHAR($PIECE(DG52,U,6)+58),1:" ")
- +11 ;marital status, sex
- +12 SET Y=Y_$SELECT($DATA(^DIC(11,+$PIECE(DG10,U,5),0)):$EXTRACT(^(0),1),1:" ")_$JUSTIFY($PIECE(DG10,U,2),1)
- +13 ; date of birth
- +14 SET DGDOB=$PIECE(DG10,U,3)\1
- SET Y=Y_$EXTRACT(DGDOB,4,5)_$EXTRACT(DGDOB,6,7)_(1700+$EXTRACT(DGDOB,1,3))
- +15 ; period of service
- +16 SET DGPOS=$SELECT($DATA(^DIC(21,+$PIECE(DG32,U,3),0)):$PIECE(^(0),U,3),1:"")
- +17 IF $DATA(^DGPM(+$ORDER(^DGPM("APTF",J,0)),"ODS"))
- IF +^("ODS")
- SET DGPOS=6
- +18 ;-- if non vet admitting eligibility make POS 9
- +19 SET DGPOS=$$CKPOS^DGPTUTL($PIECE($GET(^DGPT(PTF,101)),U,8),DGPOS)
- +20 SET X=DGPOS
- SET Z=1
- SET L=2
- DO ENTER
- +21 ; agent orange
- +22 SET G=" "
- SET DGAO=$PIECE(DG321,U,2)
- if DGPOS=7
- SET G=$SELECT($PIECE(DG321,U)'="Y":1,DGAO="N":2,DGAO="Y":3,1:4)
- if (DGAO="Y")&($PIECE(DG321,U,13)="K")
- SET G=5
- +23 ; rad exposure
- +24 SET E=" "
- IF "^0^2^4^5^7^8^Z^"[(U_DGPOS_U)
- SET DGNT=$PIECE(DG321,U,12)
- SET E=$SELECT($PIECE(DG321,U,3)'="Y":1,DGNT="N":2,DGNT="T":3,DGNT="B":4,1:" ")
- +25 SET Y=Y_G_E
- KILL DGPOS,G,E
- +26 ; state code
- +27 SET X=$SELECT($DATA(^DIC(5,+$PIECE(DG11,U,5),0)):^(0),1:"")
- SET L=2
- SET Z=3
- DO ENTER0
- +28 ; county code
- +29 SET X=$SELECT($DATA(^DIC(5,+$PIECE(DG11,U,5),1,+$PIECE(DG11,U,7),0)):^(0),1:"")
- SET L=3
- SET Z=3
- DO ENTER0
- +30 ; zip code
- +31 SET X=DG11
- SET Z=6
- SET L=5
- DO ENTER
- +32 ; means test
- +33 SET Y=Y_$SELECT($PIECE(DG70,U,26)="Y":"AS",1:$EXTRACT($PIECE(DG0,U,10)_" ",1,2))
- +34 ; income
- +35 IF $LENGTH($PIECE(DG101,U,7))>6
- SET Y=Y_"999999"
- +36 IF '$TEST
- SET X=DG101
- SET Z=7
- SET L=6
- DO ENTER0
- +37 ;MST
- +38 SET X=$$GETSTAT^DGMSTAPI(+DG0)
- SET Y=Y_$SELECT(X<0:"U",1:$PIECE(X,"^",2))
- +39 ;Combat Vet
- +40 SET X=$$CVEDT^DGCV(+DG0,$PIECE(DG0,"^",2))
- SET Y=Y_$SELECT((+X)>0:1,1:0)
- +41 SET X=$PIECE(X,"^",2)_" "
- SET Y=Y_$EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)
- +42 ;Project 112/SHAD
- +43 SET X=$$SHAD^SDCO22(+DG0)
- SET Y=Y_$SELECT((+X)>0:1,1:0)
- +44 ;Emergency Response Indicator
- +45 SET X=$$EMGRES^DGUTL(+DG0)
- SET Y=Y_$SELECT("^K^"[(U_X_U):X,1:" ")
- +46 ;Country Code
- +47 SET X=$$GET1^DIQ(779.004,$PIECE(DG11,U,10)_",",.01)
- SET Z=1
- SET L=3
- DO ENTER
- +48 DO FILL^DGPTR2
- DO SAVE
- +49 ;I T1 S Y=$E(Y,1,52)_" "_$E(Y,54,125)
- +50 ;sets $E(Y,53)=" " if census, but why after it is saved?
- IF T1
- SET $EXTRACT(Y,53)=" "
- +51 ;
- P401 ; -- setup 401P transaction
- +1 if '$DATA(^DGPT(J,"401P"))!(T1)
- GOTO 401
- SET DG41=^("401P")
- SET Y=$SELECT(T1:"C",1:"N")_"401"_DGHEAD_"P"_" "
- +2 NEW EFFDATE,IMPDATE,DGPTDAT
- DO EFFDATE^DGPTIC10(J)
- +3 SET DG41=$SELECT($DATA(^DGPT(J,"401P")):^("401P"),1:"")
- +4 SET L=1
- FOR K=1:1:5
- if '$PIECE(DG41,U,K)
- SET DG41=$PIECE(DG41,U,1,K-1)_U_$PIECE(DG41,U,K+1,99)
- SET K=K-1
- SET L=L+1
- if L=5
- QUIT
- +5 FOR I=1:1:5
- SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$PIECE(DG41,U,I),EFFDATE,"I")
- SET Y=Y_$SELECT(+DGPTTMP>0:$JUSTIFY($PIECE($PIECE(DGPTTMP,U,2),".",1),2)_$EXTRACT($PIECE($PIECE(DGPTTMP,U,2),".",2)_" ",1,3),1:" ")_" "
- +6 KILL DGPTEDT
- +7 IF $EXTRACT(Y,40)'=" "
- DO FILL^DGPTR2
- DO SAVE
- +8 ;
- 401 ; -- setup 401 transactions
- +1 if '$DATA(^DGPT(J,"S"))
- GOTO 501
- KILL ^UTILITY($JOB,"S")
- SET I=0
- SUR ;
- +1 SET I=$ORDER(^DGPT(J,"S",I))
- if 'I
- GOTO 501
- SET DGSUR=^(I,0)
- SET DGAUX=$SELECT($DATA(^DGPT(J,"S",I,300)):^(300),1:"")
- if 'DGSUR
- GOTO SUR
- +2 if DGSUR<T1!(DGSUR>T2)
- GOTO SUR
- SET DGSUD=+^(0)\1
- SET ^UTILITY($JOB,"S",DGSUD)=$SELECT($DATA(^UTILITY($JOB,"S",DGSUD)):^(DGSUD),1:0)+1
- SET F=$SELECT(DGSUD<2871000:0,1:1)
- +3 IF ^UTILITY($JOB,"S",DGSUD)>$SELECT(F:3,1:2)
- Begin DoDot:1
- +4 WRITE !,"**There are more than ",$SELECT(F:"three",1:"two")," surgeries on the same date**"
- +5 SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="OK to continue?"
- DO ^DIR
- KILL DIR
- End DoDot:1
- IF Y'=1
- SET DGERR=1
- QUIT
- +6 SET Y=$SELECT(T1:"C",1:"N")_"401"_DGHEAD_$EXTRACT(DGSUD,4,5)_$EXTRACT(DGSUD,6,7)_$EXTRACT(DGSUD,2,3)_$EXTRACT($PIECE(+DGSUR,".",2)_"0000",1,4)_$SELECT($DATA(^DIC(45.3,+$PIECE(DGSUR,U,3),0)):$PIECE(^(0),U,1),1:" ")
- +7 SET L=1
- SET X=DGSUR
- FOR Z=4:1:7
- DO ENTER
- +8 NEW EFFDATE,IMPDATE,DGPTDAT
- DO EFFDATE^DGPTIC10(J)
- +9 SET L=1
- FOR K=8:1:12
- if '$PIECE(DGSUR,U,K)
- SET DGSUR=$PIECE(DGSUR,U,1,K-1)_U_$PIECE(DGSUR,U,K+1,99)
- SET K=K-1
- SET L=L+1
- if L=5
- QUIT
- +10 FOR K=8:1:12
- SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$PIECE(DGSUR,U,K),EFFDATE,"I")
- SET Y=Y_$SELECT(+DGPTTMP>0:$JUSTIFY($PIECE($PIECE(DGPTTMP,U,2),".",1),2)_$EXTRACT($PIECE($PIECE(DGPTTMP,U,2),".",2)_" ",1,3),1:" ")_" "
- +11 ;
- +12 ;-- att phy
- +13 SET Y=Y_" "
- +14 ;-- additional ptf question
- +15 ;send null, if disch date>inactive date. DG/729
- +16 IF +$PIECE($GET(^DIC(45.88,1,0)),U,3)
- SET DGAUX=$SELECT((+$GET(^DGPT(J,70))<$PIECE(^DIC(45.88,1,0),U,3)):DGAUX,1:"")
- +17 SET Y=Y_$EXTRACT($PIECE(DGAUX,U)_" ")
- +18 KILL DGAUX
- +19 DO FILL^DGPTR2
- DO SAVE
- GOTO SUR
- 501 GOTO 501^DGPTR2
- +1 QUIT
- ENTER SET Y=Y_$JUSTIFY($PIECE(X,U,Z),L)
- +1 QUIT
- ENTER0 SET Y=Y_$SELECT($PIECE(X,U,Z)]"":$EXTRACT("000000",$LENGTH($PIECE(X,U,Z))+1,L)_$PIECE(X,U,Z),1:$JUSTIFY($PIECE(X,U,Z),L))
- +1 QUIT
- SAVE ;save segment to MailMan message and ^TMP("AEDIT",$J), if data is valid
- +1 DO SAVE^DGPTR2
- Q QUIT
- DGNAM SET X=DGNAM
- IF X?.E.P
- FOR I=1:1:$LENGTH(X)
- SET Z=$EXTRACT(X,I)
- if Z=","
- QUIT
- if Z?.P&(Z]"")
- SET X=$EXTRACT(X,1,I-1)_$EXTRACT(X,I+1,$LENGTH(X))
- SET I=I-1
- if X'?.E.P
- QUIT
- +1 IF X?.E.L
- DO UP^DGHELP
- +2 SET DGNAM=X
- +3 QUIT
- +4 ;
- PTFNMFT(DG10) ;this function will format the name of the patient for
- +1 ; transmission of the 101 record to Austin. In addition, this
- +2 ; function will be used by OPC so that the format will be consistent
- +3 ; for OPC and PTF.
- +4 ; INPUT : DG10 - .01 field from the patient record.
- +5 ; OUTPUT: name in the format proper format.
- +6 ; A = <12 - characters of last name padded with blanks>
- +7 ; B = <1 - first initial of fist name>
- +8 ; C = <1 - first initial of middle name>
- +9 ; returns :ABC <14 - characters>
- +10 NEW X,I
- +11 SET DGNAM=DG10
- DO DGNAM
- +12 QUIT $EXTRACT($PIECE(DGNAM,",",1)_" ",1,12)_$JUSTIFY($EXTRACT($PIECE(DGNAM,",",2),1),1)_$JUSTIFY($EXTRACT($PIECE($PIECE(DGNAM,",",2)," ",2),1),1)