DGPTRPO.m

DGPTRPO ;ALB/MTC,HIOFO/FT - RECORD PRINT OUT (RPO);5/26/15 3:24pm

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

 ;

 ; VATRAN - #1011

 ; XMD - #10070

 ; VASITE - #10112

 ; XMA2 - #10066

 ; ^XMB(3.9) - #10113

 ; ^VA(200) - #10060

 ; %ZIS - #10086

 ; ^DPT - #10035

 ; XLFSTR - #10104

 ;

EN ;-- generic N15x call. Record Print-Out (RPO) [DGPTTOOL RPO]

 D INIT G ENQ:DGOUT

 D FMT G ENQ:DGOUT

 S DIC="^DGP(45.87,",DIC(0)="L" K DO,DD D NOW^%DTC S X=% D FILE^DICN K DIC,DO

 G ENQ:Y<0 S (DA,DGDA)=+Y

EDIT S DIE="^DGP(45.87,",(DR,DGDR)=$S(DGCTL="N150":"[DGPT 150]",1:"[DGPT 151]")

 S DGPAT=$P(^DGP(45.87,DGDA,0),U,9),DGINST=$P(^DGP(45.87,DGDA,0),U,10)

 F DGI=0:0 S DA=DGDA,DR=DGDR D ^DIE,CHKFLD Q:'DGOUT  D ASK I DGOUT D DEL,ENQ G EN

SEND S DGOUT=0,DIR(0)="Y",DIR("A")="Ok to Send "_DGCTL,DIR("B")="YES"

 D ^DIR I $D(DIRUT)!(Y=0) D ASK G EDIT:'DGOUT I DGOUT D DEL,ENQ G EN

 I Y D PRETRAN G:DGOUT EN D

 .K X S $P(X," ",241)=""

 .S:$E(DGSSN,10)="P" DGSSN="P"_$E(DGSSN,1,9)

 .S ^XMB(3.9,XMZ,2,1,0)=$E(DGCTL_$J(DGSSN,10)_$J(DGADM,10)_$J(DGFAC,6)_$J(DGRFAC,6)_X,1,240)

 .S ^XMB(3.9,XMZ,2,2,0)=$$REPEAT^XLFSTR(" ",144)

 .D TRAN W !,"****** ",DGCTL," TRANSACTION SENT ******"

 D ENQ G EN

ENQ K %,DGDR,DGDA,DGPAT,DGINST,DGFNAM,DGNAME,DGCTL,DGTADM,DA,DGRPO,DIR,DIE,DIK,X,Y,DGOUT,VATNAME,VATERR,VAT,DIROUT,DIRUT,XMTEXT,XMSUB,XMDUZ,XMDUN,DGSSN,DGADM,DGRFAC,DGFAC,DIC,DR,DD,DO,DGDA,DGI,DQ,DB,DE

 Q

 ;

CHKFLD ;-- check data for valid entries

 S DGOUT=0

 I '$D(^DGP(45.87,DGDA,0)) S DGOUT=1 G CHKFLDQ

 S DGRPO=^DGP(45.87,DGDA,0)

 I DGCTL="N150" F DGJ=5:1:8 I $P(DGRPO,U,DGJ)="" S DGOUT=1 D CHKERR

 I DGCTL="N151" F DGJ=5,8 I $P(DGRPO,U,DGJ)="" S DGOUT=1 D CHKERR

 I DGCTL="N099" F DGJ=5,6,8 I $P(DGRPO,U,DGJ)="" S DGOUT=1 D CHKERR

 I +$P(DGRPO,U,9) S DGNAME=$P(^DPT($P(DGRPO,U,9),0),U)

CHKFLDQ ;

 K DGRPO,DGJ

 Q

CHKERR ;

 W !,"*** ",$P("^^^^SSN^ADMISSION DATE/TIME^ADMITTING FACILITY NUMBER/SUFFIX^REQUESTING FACILITY NUMBER/SUFFIX","^",DGJ)," field is empty."

 Q

 ;

ASK ;-- On error in record check for re-edit

 S DGOUT=0

 S DIR(0)="Y",DIR("A")="Would you like to EDIT the "_DGCTL_" record",DIR("B")="YES"

 D ^DIR

 I $D(DIRUT)!(Y=0) S DGOUT=1

ASKQ K DIR

 Q

 ;

HDRPX ;called from [DGPT 150] and [DGPT 151] input templates

 W @IOF,$C(13),?18,">>> Facsimile of ",DGCTL," Transaction <<<"

 W:DGNAME]"" !,"           Patient : ",DGNAME

 W:DGFNAM]"" !,"Admitting Facility : ",DGFNAM

 S:$E(DGSSN,10)="P" DGSSN="P"_$E(DGSSN,1,9)

 W !!?9,"'",$J(DGCTL,4),"'   '",$J(DGSSN,10),"'   '",$J(DGADM,10),"'   '",$J(DGFAC,6),"'   '",$J(DGRFAC,6),"'"

 W !?2,"col# :"

 W ?10,"1--4     5--------1     1--------2     2----3     3----3",!

 W ?10,"                  4     5        4     5    0     1    6",!

 W !?2,"block:"

 W ?10,"         SSN            Admission     Admitting   Requesting",!

 W ?10,"                        Date/Time     Facility    Facility",!

 W ?10,"                                      Num/Suffix  Num/Suffix",!!

 I DGCTL="N151" W !,"For the 151 the Admission DATE/TIME and",!,"the Admitting Facility Num/Suffix CANNOT be filled in.",!!

 Q

 ;

FMT ;-- select format 150/151; set trans router to PTF125

 S DGOUT=0

 S DGOUT=0,DIR(0)="SB^150:N150 SPECIFIC (RPO);151:N151 GENERAL (RPO);EXIT:EXIT",DIR("A")="Which RPO Format",DIR("?")="Enter 150 or 151 for the Record Print-Out (RPO) form to be sent.",DIR("B")="EXIT"

 W @IOF D ^DIR I $D(DIRUT)!(Y="EXIT") S DGOUT=1 G FMTQ

 S DGY=Y

 S DGCTL=$S(DGY=150:"N150",1:"N151")

 S VATNAME="PTF125" D ^VATRAN I VATERR S DGOUT=1 G FMTQ

FMTQ K DGY,DIR,DIRUT Q

 ;

PRETRAN ;-- get mailman msg #

 S DGOUT=0,XMSUB="PTF "_DGCTL,XMDUZ=DUZ

 D GET^XMA2

 I $D(XMZ),XMZ>0 G PREQ

 W !!,"*** ERROR *** Unable to create Mail Message... Try again later." S DGOUT=1

PREQ Q

TRAN ;

 K XMY D ROUTER^DGPTFTR

 S XMDUN=$P(^VA(200,DUZ,0),U),^XMB(3.9,XMZ,2,0)="^3.92A^1^1^"_DT

 D ENT1^XMD

 S DIE="^DGP(45.87,",DA=DGDA,DR=".03////"_XMZ D ^DIE

 K XMZ,DIE,DR

 Q

 ;

DEL ;-- KILL ENTRY 

 S DA=DGDA,DIK="^DGP(45.87," D ^DIK

 Q

 ;

INIT ;

 D LO^DGUTL,HOME^%ZIS S DGOUT=0

 S (DGPAT,DGINST,DGCTL,DGTADM,DGSSN,DGADM,DGFAC,DGFNAM,DGNAME)="",DGRFAC=$E($P($$SITE^VASITE,U,3)_"      ",1,6)

INITQ Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DGPTRPO   4178     printed  Feb 19, 2025@00:19:35                                                                                                                                                                                                     Page 2

DGPTRPO   ;ALB/MTC,HIOFO/FT - RECORD PRINT OUT (RPO);5/26/15 3:24pm

 +1       ;;5.3;Registration;**884**;Aug 13, 1993;Build 31

 +2       ;

 +3       ; VATRAN - #1011

 +4       ; XMD - #10070

 +5       ; VASITE - #10112

 +6       ; XMA2 - #10066

 +7       ; ^XMB(3.9) - #10113

 +8       ; ^VA(200) - #10060

 +9       ; %ZIS - #10086

 +10      ; ^DPT - #10035

 +11      ; XLFSTR - #10104

 +12      ;

EN        ;-- generic N15x call. Record Print-Out (RPO) [DGPTTOOL RPO]

 +1        DO INIT

           if DGOUT

               GOTO ENQ

 +2        DO FMT

           if DGOUT

               GOTO ENQ

 +3        SET DIC="^DGP(45.87,"

           SET DIC(0)="L"

           KILL DO,DD

           DO NOW^%DTC

           SET X=%

           DO FILE^DICN

           KILL DIC,DO

 +4        if Y<0

               GOTO ENQ

           SET (DA,DGDA)=+Y

EDIT       SET DIE="^DGP(45.87,"

           SET (DR,DGDR)=$SELECT(DGCTL="N150":"[DGPT 150]",1:"[DGPT 151]")

 +1        SET DGPAT=$PIECE(^DGP(45.87,DGDA,0),U,9)

           SET DGINST=$PIECE(^DGP(45.87,DGDA,0),U,10)

 +2        FOR DGI=0:0

               SET DA=DGDA

               SET DR=DGDR

               DO ^DIE

               DO CHKFLD

               if 'DGOUT

                   QUIT 

               DO ASK

               IF DGOUT

                   DO DEL

                   DO ENQ

                   GOTO EN

SEND       SET DGOUT=0

           SET DIR(0)="Y"

           SET DIR("A")="Ok to Send "_DGCTL

           SET DIR("B")="YES"

 +1        DO ^DIR

           IF $DATA(DIRUT)!(Y=0)

               DO ASK

               if 'DGOUT

                   GOTO EDIT

               IF DGOUT

                   DO DEL

                   DO ENQ

                   GOTO EN

 +2        IF Y

               DO PRETRAN

               if DGOUT

                   GOTO EN

               Begin DoDot:1

 +3                KILL X

                   SET $PIECE(X," ",241)=""

 +4                if $EXTRACT(DGSSN,10)="P"

                       SET DGSSN="P"_$EXTRACT(DGSSN,1,9)

 +5                SET ^XMB(3.9,XMZ,2,1,0)=$EXTRACT(DGCTL_$JUSTIFY(DGSSN,10)_$JUSTIFY(DGADM,10)_$JUSTIFY(DGFAC,6)_$JUSTIFY(DGRFAC,6)_X,1,240)

 +6                SET ^XMB(3.9,XMZ,2,2,0)=$$REPEAT^XLFSTR(" ",144)

 +7                DO TRAN

                   WRITE !,"****** ",DGCTL," TRANSACTION SENT ******"

               End DoDot:1

 +8        DO ENQ

           GOTO EN

ENQ        KILL %,DGDR,DGDA,DGPAT,DGINST,DGFNAM,DGNAME,DGCTL,DGTADM,DA,DGRPO,DIR,DIE,DIK,X,Y,DGOUT,VATNAME,VATERR,VAT,DIROUT,DIRUT,XMTEXT,XMSUB,XMDUZ,XMDUN,DGSSN,DGADM,DGRFAC,DGFAC,DIC,DR,DD,DO,DGDA,DGI,DQ,DB,DE

 +1        QUIT 

 +2       ;

CHKFLD    ;-- check data for valid entries

 +1        SET DGOUT=0

 +2        IF '$DATA(^DGP(45.87,DGDA,0))

               SET DGOUT=1

               GOTO CHKFLDQ

 +3        SET DGRPO=^DGP(45.87,DGDA,0)

 +4        IF DGCTL="N150"

               FOR DGJ=5:1:8

                   IF $PIECE(DGRPO,U,DGJ)=""

                       SET DGOUT=1

                       DO CHKERR

 +5        IF DGCTL="N151"

               FOR DGJ=5,8

                   IF $PIECE(DGRPO,U,DGJ)=""

                       SET DGOUT=1

                       DO CHKERR

 +6        IF DGCTL="N099"

               FOR DGJ=5,6,8

                   IF $PIECE(DGRPO,U,DGJ)=""

                       SET DGOUT=1

                       DO CHKERR

 +7        IF +$PIECE(DGRPO,U,9)

               SET DGNAME=$PIECE(^DPT($PIECE(DGRPO,U,9),0),U)

CHKFLDQ   ;

 +1        KILL DGRPO,DGJ

 +2        QUIT 

CHKERR    ;

 +1        WRITE !,"*** ",$PIECE("^^^^SSN^ADMISSION DATE/TIME^ADMITTING FACILITY NUMBER/SUFFIX^REQUESTING FACILITY NUMBER/SUFFIX","^",DGJ)," field is empty."

 +2        QUIT 

 +3       ;

ASK       ;-- On error in record check for re-edit

 +1        SET DGOUT=0

 +2        SET DIR(0)="Y"

           SET DIR("A")="Would you like to EDIT the "_DGCTL_" record"

           SET DIR("B")="YES"

 +3        DO ^DIR

 +4        IF $DATA(DIRUT)!(Y=0)

               SET DGOUT=1

ASKQ       KILL DIR

 +1        QUIT 

 +2       ;

HDRPX     ;called from [DGPT 150] and [DGPT 151] input templates

 +1        WRITE @IOF,$CHAR(13),?18,">>> Facsimile of ",DGCTL," Transaction <<<"

 +2        if DGNAME]""

               WRITE !,"           Patient : ",DGNAME

 +3        if DGFNAM]""

               WRITE !,"Admitting Facility : ",DGFNAM

 +4        if $EXTRACT(DGSSN,10)="P"

               SET DGSSN="P"_$EXTRACT(DGSSN,1,9)

 +5        WRITE !!?9,"'",$JUSTIFY(DGCTL,4),"'   '",$JUSTIFY(DGSSN,10),"'   '",$JUSTIFY(DGADM,10),"'   '",$JUSTIFY(DGFAC,6),"'   '",$JUSTIFY(DGRFAC,6),"'"

 +6        WRITE !?2,"col# :"

 +7        WRITE ?10,"1--4     5--------1     1--------2     2----3     3----3",!

 +8        WRITE ?10,"                  4     5        4     5    0     1    6",!

 +9        WRITE !?2,"block:"

 +10       WRITE ?10,"         SSN            Admission     Admitting   Requesting",!

 +11       WRITE ?10,"                        Date/Time     Facility    Facility",!

 +12       WRITE ?10,"                                      Num/Suffix  Num/Suffix",!!

 +13       IF DGCTL="N151"

               WRITE !,"For the 151 the Admission DATE/TIME and",!,"the Admitting Facility Num/Suffix CANNOT be filled in.",!!

 +14       QUIT 

 +15      ;

FMT       ;-- select format 150/151; set trans router to PTF125

 +1        SET DGOUT=0

 +2        SET DGOUT=0

           SET DIR(0)="SB^150:N150 SPECIFIC (RPO);151:N151 GENERAL (RPO);EXIT:EXIT"

           SET DIR("A")="Which RPO Format"

           SET DIR("?")="Enter 150 or 151 for the Record Print-Out (RPO) form to be sent."

           SET DIR("B")="EXIT"

 +3        WRITE @IOF

           DO ^DIR

           IF $DATA(DIRUT)!(Y="EXIT")

               SET DGOUT=1

               GOTO FMTQ

 +4        SET DGY=Y

 +5        SET DGCTL=$SELECT(DGY=150:"N150",1:"N151")

 +6        SET VATNAME="PTF125"

           DO ^VATRAN

           IF VATERR

               SET DGOUT=1

               GOTO FMTQ

FMTQ       KILL DGY,DIR,DIRUT

           QUIT 

 +1       ;

PRETRAN   ;-- get mailman msg #

 +1        SET DGOUT=0

           SET XMSUB="PTF "_DGCTL

           SET XMDUZ=DUZ

 +2        DO GET^XMA2

 +3        IF $DATA(XMZ)

               IF XMZ>0

                   GOTO PREQ

 +4        WRITE !!,"*** ERROR *** Unable to create Mail Message... Try again later."

           SET DGOUT=1

PREQ       QUIT 

TRAN      ;

 +1        KILL XMY

           DO ROUTER^DGPTFTR

 +2        SET XMDUN=$PIECE(^VA(200,DUZ,0),U)

           SET ^XMB(3.9,XMZ,2,0)="^3.92A^1^1^"_DT

 +3        DO ENT1^XMD

 +4        SET DIE="^DGP(45.87,"

           SET DA=DGDA

           SET DR=".03////"_XMZ

           DO ^DIE

 +5        KILL XMZ,DIE,DR

 +6        QUIT 

 +7       ;

DEL       ;-- KILL ENTRY 

 +1        SET DA=DGDA

           SET DIK="^DGP(45.87,"

           DO ^DIK

 +2        QUIT 

 +3       ;

INIT      ;

 +1        DO LO^DGUTL

           DO HOME^%ZIS

           SET DGOUT=0

 +2        SET (DGPAT,DGINST,DGCTL,DGTADM,DGSSN,DGADM,DGFAC,DGFNAM,DGNAME)=""

           SET DGRFAC=$EXTRACT($PIECE($$SITE^VASITE,U,3)_"      ",1,6)

INITQ      QUIT