Routine: DGPTRI0

DGPTRI0 ;MJK/JS/ADL/TJ,ISF/GJW,HIOFO/FT - PTF TRANSMISSION ;4/9/15 2:57pm

 ;;5.3;Registration;**850,884**;Aug 13, 1993;Build 31

 ;;ADL;Update for CSV Project;;Mar 27, 2003

 ; ICDXCODE APIs - 5699

 ; SDCO22 APIs - 1579

 ; XLFSTR APIs - 10104

 ; -- 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^DGPTRI1

101 ; -- setup 101 transmission

 ; control data and name

 S $E(Y,1,30)=$S(T1:"C",1:"N")_"101"_DGHEAD

 S $E(Y,31,44)=$$PTFNMFT($P(DG10,U))

 ; source of admission - $E(Y,45,46)

 S $E(Y,45,46)=$S($D(^DIC(45.1,+DG101,0)):$J($P(^(0),U,1),2),1:"  ")

 ; xfring fac and suffix - $E(Y,47,49) & $E(Y,50,52)

 S L=3,X=DG101,Z=5 D FORMAT S $E(Y,47,49)=DGVALUE S $E(Y,50,52)=$E($P(X,U,6)_"   ",1,3)

 ; source of payment - $E(Y,53)

 S $E(Y,53)=$S("A0"[$P(DG0,U,5):" ",1:$J($P(DG101,U,3),1))

 ;POW Location $E(Y,54)

 S $E(Y,54)=$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 - $E(Y,55) & $E(Y,56)

 S $E(Y,55,56)=$S($D(^DIC(11,+$P(DG10,U,5),0)):$E(^(0),1),1:" ")_$J($P(DG10,U,2),1)

 ;  date of birth - $E(Y,57,64)

 S DGDOB=$P(DG10,U,3)\1,$E(Y,57,64)=$E(DGDOB,4,5)_$E(DGDOB,6,7)_(1700+$E(DGDOB,1,3))

 S $E(Y,65)=" " ;blank, not used

 ; period of service - $E(Y,66)

 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=1 D FORMAT S $E(Y,66)=DGVALUE

 ; agent orange - $E(Y,67)

 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 - $E(Y,68)

 ;patch 884 - use the correct numeric codes (from the DD)

 S E=" " I "^0^2^4^5^7^8^Z^"[(U_DGPOS_U) S (E,DGNT)=$P(DG321,U,12)

 S $E(Y,67,68)=G_E K DGPOS,G,E

 ; state code - $E(Y,69,70)

 S X=$S($D(^DIC(5,+$P(DG11,U,5),0)):^(0),1:""),L=2,Z=3 D FORMAT0 S $E(Y,69,70)=DGVALUE0

 ; county code - $E(Y,71,73)

 S X=$S($D(^DIC(5,+$P(DG11,U,5),1,+$P(DG11,U,7),0)):^(0),1:""),L=3,Z=3 D FORMAT0 S $E(Y,71,73)=DGVALUE0

 ; zip code - $E(Y,74,78)

 S X=DG11,Z=6,L=5 D FORMAT S $E(Y,74,78)=DGVALUE

 ; means test - $E(Y,79,80)

 S $E(Y,79,80)=$S($P(DG70,U,26)="Y":"AS",1:$E($P(DG0,U,10)_"  ",1,2))

 ; income - $E(Y,81,86)

 I $L($P(DG101,U,7))>6 S $E(Y,81,86)="999999"

 E  S X=DG101,Z=7,L=6 D FORMAT0 S $E(Y,81,86)=DGVALUE0

 ;MST - $E(Y,87)

 S X=$$GETSTAT^DGMSTAPI(+DG0) S $E(Y,87)=$S(X<0:"U",1:$P(X,"^",2))

 ;Combat Vet $E(Y,88) & $E(Y,89,94)

 S X=$$CVEDT^DGCV(+DG0,$P(DG0,"^",2)) S $E(Y,88)=$S((+X)>0:1,1:0)

 S X=$P(X,"^",2)_"       " S $E(Y,89,94)=$E(X,4,5)_$E(X,6,7)_$E(X,2,3)

 ;Project 112/SHAD - $E(Y,95)

 S X=$$SHAD^SDCO22(+DG0) S $E(Y,95)=$S((+X)>0:1,1:0)

 ;Emergency Response Indicator - $E(Y,96)

 S X=$$EMGRES^DGUTL(+DG0) S $E(Y,96)=$S("^K^"[(U_X_U):X,1:" ")

 ;Country Code - $E(Y,97,99)

 S X=$$GET1^DIQ(779.004,$P(DG11,U,10)_",",.01),Z=1,L=3 D FORMAT S $E(Y,97,99)=DGVALUE

 ;[RESERVED] - $E(Y,100,112)

 ;[NOT ALLOCATED] - $E(Y,113,384)

 K DGVALUE,DGVALUE0

 D SAVE

 I T1 S Y=$E(Y,53)=" " ;resets SOURCE OF PAYMENT to space

401 ; -- setup 401 transactions (402 and 403 are no longer used. All surgeries are 401 segments.)

 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=^DGPT(J,"S",I,0)

 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) ;^(0) references global 2 lines above

 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

 ;header, date of surgery followed by SPECIALTY - $E(Y,41,42)

 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:"  ")

 ;4 is CATEGORY OF CHIEF SURGEON - $E(Y,43)

 ;5 is CATEGORY OF FIRST ASSISTANT - $E(Y,44)

 ;6 is ANESTHESIA TECHNIQUE (PRINCIPAL) - $E(Y,45)

 ;7 is SOURCE OF PAYMENT - $E(Y,46)

 S L=1,X=DGSUR F Z=4:1:7 D ENTER

 N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)

 ;operation codes 1 - 25 - $E(Y,47,246)

 N DG401CODES,DGLOOP,DGOCODE,DGSTRING,DGPTTMP

 D PTFICD^DGPTFUT(401,J,I,.DG401CODES) ;get procedure values

 S DGLOOP=0,DGSTRING=""

 F  S DGLOOP=$O(DG401CODES(DGLOOP)) Q:DGLOOP=""  D

 .S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$P(DG401CODES(DGLOOP),U,1),EFFDATE,"I") ;check data

 .Q:+DGPTTMP'>0  ;don't use if bad

 .S DGOCODE=$P(DG401CODES(DGLOOP),U,3) ;external value

 .S DGSTRING=DGSTRING_DGOCODE_" " ;append space to pad to 8 characters

 S $E(Y,47,246)=DGSTRING_$$REPEAT^XLFSTR(" ",200-$L(DGSTRING))

 ;-- att phy [NOT ACTIVATED - $E(Y,247,256)]

 S $E(Y,247,256)="         "

 ;[RESERVED - $E(Y,256,290)]

 ;[NOT ALLOCATED - $E(Y,291,384)]

 D SAVE G SUR

501 G 501^DGPTRI2

FORMAT ;format value

 S DGVALUE=$J($P(X,U,Z),L)

FORMAT0 ;format value with zeros

 S DGVALUE0=$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))

ENTER S Y=Y_$J($P(X,U,Z),L)

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))

SAVE ;

 D SAVE^DGPTRI2

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

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[HDGPTRI0   6530     printed  Feb 19, 2025@00:19:29                                                                                                                                                                                                     Page 2

DGPTRI0   ;MJK/JS/ADL/TJ,ISF/GJW,HIOFO/FT - PTF TRANSMISSION ;4/9/15 2:57pm

 +1       ;;5.3;Registration;**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       ; XLFSTR APIs - 10104

 +7       ;

 +8       ; -- setup control data

 +9       ; ssn

 +10       SET X=$PIECE(DG10,U,9)

           SET Y=$SELECT($EXTRACT(X,10)="P":"P",1:" ")_$EXTRACT(X_"         ",1,9)

 +11      ; -- adm d/t

 +12       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)

 +13      ; -- facility #

 +14       SET L=3

           SET X=DG0

           SET Z=3

           DO ENTER

           SET Y=Y_$EXTRACT($PIECE(X,U,5)_"   ",1,3)

 +15       SET DGHEAD=Y

           SET Y="    "_Y

           DO HEAD^DGPTRI1

 +16      ;

101       ; -- setup 101 transmission

 +1       ; control data and name

 +2        SET $EXTRACT(Y,1,30)=$SELECT(T1:"C",1:"N")_"101"_DGHEAD

 +3        SET $EXTRACT(Y,31,44)=$$PTFNMFT($PIECE(DG10,U))

 +4       ; source of admission - $E(Y,45,46)

 +5        SET $EXTRACT(Y,45,46)=$SELECT($DATA(^DIC(45.1,+DG101,0)):$JUSTIFY($PIECE(^(0),U,1),2),1:"  ")

 +6       ; xfring fac and suffix - $E(Y,47,49) & $E(Y,50,52)

 +7        SET L=3

           SET X=DG101

           SET Z=5

           DO FORMAT

           SET $EXTRACT(Y,47,49)=DGVALUE

           SET $EXTRACT(Y,50,52)=$EXTRACT($PIECE(X,U,6)_"   ",1,3)

 +8       ; source of payment - $E(Y,53)

 +9        SET $EXTRACT(Y,53)=$SELECT("A0"[$PIECE(DG0,U,5):" ",1:$JUSTIFY($PIECE(DG101,U,3),1))

 +10      ;POW Location $E(Y,54)

 +11       SET $EXTRACT(Y,54)=$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:" ")

 +12      ;marital status, sex - $E(Y,55) & $E(Y,56)

 +13       SET $EXTRACT(Y,55,56)=$SELECT($DATA(^DIC(11,+$PIECE(DG10,U,5),0)):$EXTRACT(^(0),1),1:" ")_$JUSTIFY($PIECE(DG10,U,2),1)

 +14      ;  date of birth - $E(Y,57,64)

 +15       SET DGDOB=$PIECE(DG10,U,3)\1

           SET $EXTRACT(Y,57,64)=$EXTRACT(DGDOB,4,5)_$EXTRACT(DGDOB,6,7)_(1700+$EXTRACT(DGDOB,1,3))

 +16      ;blank, not used

           SET $EXTRACT(Y,65)=" "

 +17      ; period of service - $E(Y,66)

 +18       SET DGPOS=$SELECT($DATA(^DIC(21,+$PIECE(DG32,U,3),0)):$PIECE(^(0),U,3),1:"")

 +19       IF $DATA(^DGPM(+$ORDER(^DGPM("APTF",J,0)),"ODS"))

               IF +^("ODS")

                   SET DGPOS=6

 +20      ;-- if non vet admitting eligibility make POS 9

 +21       SET DGPOS=$$CKPOS^DGPTUTL($PIECE($GET(^DGPT(PTF,101)),U,8),DGPOS)

 +22       SET X=DGPOS

           SET Z=1

           SET L=1

           DO FORMAT

           SET $EXTRACT(Y,66)=DGVALUE

 +23      ; agent orange - $E(Y,67)

 +24       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

 +25      ; rad exposure - $E(Y,68)

 +26      ;patch 884 - use the correct numeric codes (from the DD)

 +27       SET E=" "

           IF "^0^2^4^5^7^8^Z^"[(U_DGPOS_U)

               SET (E,DGNT)=$PIECE(DG321,U,12)

 +28       SET $EXTRACT(Y,67,68)=G_E

           KILL DGPOS,G,E

 +29      ; state code - $E(Y,69,70)

 +30       SET X=$SELECT($DATA(^DIC(5,+$PIECE(DG11,U,5),0)):^(0),1:"")

           SET L=2

           SET Z=3

           DO FORMAT0

           SET $EXTRACT(Y,69,70)=DGVALUE0

 +31      ; county code - $E(Y,71,73)

 +32       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 FORMAT0

           SET $EXTRACT(Y,71,73)=DGVALUE0

 +33      ; zip code - $E(Y,74,78)

 +34       SET X=DG11

           SET Z=6

           SET L=5

           DO FORMAT

           SET $EXTRACT(Y,74,78)=DGVALUE

 +35      ; means test - $E(Y,79,80)

 +36       SET $EXTRACT(Y,79,80)=$SELECT($PIECE(DG70,U,26)="Y":"AS",1:$EXTRACT($PIECE(DG0,U,10)_"  ",1,2))

 +37      ; income - $E(Y,81,86)

 +38       IF $LENGTH($PIECE(DG101,U,7))>6

               SET $EXTRACT(Y,81,86)="999999"

 +39      IF '$TEST

               SET X=DG101

               SET Z=7

               SET L=6

               DO FORMAT0

               SET $EXTRACT(Y,81,86)=DGVALUE0

 +40      ;MST - $E(Y,87)

 +41       SET X=$$GETSTAT^DGMSTAPI(+DG0)

           SET $EXTRACT(Y,87)=$SELECT(X<0:"U",1:$PIECE(X,"^",2))

 +42      ;Combat Vet $E(Y,88) & $E(Y,89,94)

 +43       SET X=$$CVEDT^DGCV(+DG0,$PIECE(DG0,"^",2))

           SET $EXTRACT(Y,88)=$SELECT((+X)>0:1,1:0)

 +44       SET X=$PIECE(X,"^",2)_"       "

           SET $EXTRACT(Y,89,94)=$EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)

 +45      ;Project 112/SHAD - $E(Y,95)

 +46       SET X=$$SHAD^SDCO22(+DG0)

           SET $EXTRACT(Y,95)=$SELECT((+X)>0:1,1:0)

 +47      ;Emergency Response Indicator - $E(Y,96)

 +48       SET X=$$EMGRES^DGUTL(+DG0)

           SET $EXTRACT(Y,96)=$SELECT("^K^"[(U_X_U):X,1:" ")

 +49      ;Country Code - $E(Y,97,99)

 +50       SET X=$$GET1^DIQ(779.004,$PIECE(DG11,U,10)_",",.01)

           SET Z=1

           SET L=3

           DO FORMAT

           SET $EXTRACT(Y,97,99)=DGVALUE

 +51      ;[RESERVED] - $E(Y,100,112)

 +52      ;[NOT ALLOCATED] - $E(Y,113,384)

 +53       KILL DGVALUE,DGVALUE0

 +54       DO SAVE

 +55      ;resets SOURCE OF PAYMENT to space

           IF T1

               SET Y=$EXTRACT(Y,53)=" "

 +56      ;

401       ; -- setup 401 transactions (402 and 403 are no longer used. All surgeries are 401 segments.)

 +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

 +2        SET DGSUR=^DGPT(J,"S",I,0)

 +3        if 'DGSUR

               GOTO SUR

 +4       ;^(0) references global 2 lines above

           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)

 +5       ;

 +6        IF ^UTILITY($JOB,"S",DGSUD)>$SELECT(F:3,1:2)

               Begin DoDot:1

 +7                WRITE !,"**There are more than ",$SELECT(F:"three",1:"two")," surgeries on the same date**"

 +8                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

 +9       ;

 +10      ;header, date of surgery followed by SPECIALTY - $E(Y,41,42)

 +11       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:"  ")

 +12      ;4 is CATEGORY OF CHIEF SURGEON - $E(Y,43)

 +13      ;5 is CATEGORY OF FIRST ASSISTANT - $E(Y,44)

 +14      ;6 is ANESTHESIA TECHNIQUE (PRINCIPAL) - $E(Y,45)

 +15      ;7 is SOURCE OF PAYMENT - $E(Y,46)

 +16       SET L=1

           SET X=DGSUR

           FOR Z=4:1:7

               DO ENTER

 +17       NEW EFFDATE,IMPDATE,DGPTDAT

           DO EFFDATE^DGPTIC10(J)

 +18      ;operation codes 1 - 25 - $E(Y,47,246)

 +19       NEW DG401CODES,DGLOOP,DGOCODE,DGSTRING,DGPTTMP

 +20      ;get procedure values

           DO PTFICD^DGPTFUT(401,J,I,.DG401CODES)

 +21       SET DGLOOP=0

           SET DGSTRING=""

 +22       FOR

               SET DGLOOP=$ORDER(DG401CODES(DGLOOP))

               if DGLOOP=""

                   QUIT

               Begin DoDot:1

 +23      ;check data

                   SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",$PIECE(DG401CODES(DGLOOP),U,1),EFFDATE,"I")

 +24      ;don't use if bad

                   if +DGPTTMP'>0

                       QUIT

 +25      ;external value

                   SET DGOCODE=$PIECE(DG401CODES(DGLOOP),U,3)

 +26      ;append space to pad to 8 characters

                   SET DGSTRING=DGSTRING_DGOCODE_" "

               End DoDot:1

 +27       SET $EXTRACT(Y,47,246)=DGSTRING_$$REPEAT^XLFSTR(" ",200-$LENGTH(DGSTRING))

 +28      ;-- att phy [NOT ACTIVATED - $E(Y,247,256)]

 +29       SET $EXTRACT(Y,247,256)="         "

 +30      ;[RESERVED - $E(Y,256,290)]

 +31      ;[NOT ALLOCATED - $E(Y,291,384)]

 +32       DO SAVE

           GOTO SUR

501        GOTO 501^DGPTRI2

 +1        QUIT

FORMAT    ;format value

 +1        SET DGVALUE=$JUSTIFY($PIECE(X,U,Z),L)

 +2        QUIT

FORMAT0   ;format value with zeros

 +1        SET DGVALUE0=$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))

 +2        QUIT

 +3       ;

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      ;

 +1        DO SAVE^DGPTRI2

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)

DGPTRI0.m