DGPTRPO ;ALB/MTC - RECORD PRINT OUT (RPO); 11 FEB 91
;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
EN ;-- generic N15x call
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
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 K X S $P(X," ",126)="",^XMB(3.9,XMZ,2,1,0)=$E(DGCTL_$J(DGSSN,10)_$J(DGADM,10)_$J(DGFAC,6)_$J(DGRFAC,6)_X,1,125) 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,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 W @IOF,$C(13),?18,">>> Facsimile of ",DGCTL," Transaction <<<"
W:DGNAME]"" !," Patient : ",DGNAME
W:DGFNAM]"" !,"Admitting Facility : ",DGFNAM
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
DGPTRPO ;ALB/MTC - RECORD PRINT OUT (RPO); 11 FEB 91
+1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
EN ;-- generic N15x call
+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
+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
KILL X
SET $PIECE(X," ",126)=""
SET ^XMB(3.9,XMZ,2,1,0)=$EXTRACT(DGCTL_$JUSTIFY(DGSSN,10)_$JUSTIFY(DGADM,10)_$JUSTIFY(DGFAC,6)_$JUSTIFY(DGRFAC,6)_X,1,125)
DO TRAN
WRITE !,"****** ",DGCTL," TRANSACTION SENT ******"
+3 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,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 WRITE @IOF,$CHAR(13),?18,">>> Facsimile of ",DGCTL," Transaction <<<"
+1 IF DGNAME]""
WRITE !," Patient : ",DGNAME
+2 IF DGFNAM]""
WRITE !,"Admitting Facility : ",DGFNAM
+3 WRITE !!?9,"'",$JUSTIFY(DGCTL,4),"' '",$JUSTIFY(DGSSN,10),"' '",$JUSTIFY(DGADM,10),"' '",$JUSTIFY(DGFAC,6),"' '",$JUSTIFY(DGRFAC,6),"'"
+4 WRITE !?2,"col# :"
+5 WRITE ?10,"1--4 5--------1 1--------2 2----3 3----3",!
+6 WRITE ?10," 4 5 4 5 0 1 6",!
+7 WRITE !?2,"block:"
+8 WRITE ?10," SSN Admission Admitting Requesting",!
+9 WRITE ?10," Date/Time Facility Facility",!
+10 WRITE ?10," Num/Suffix Num/Suffix",!!
+11 IF DGCTL="N151"
WRITE !,"For the 151 the Admission DATE/TIME and",!,"the Admitting Facility Num/Suffix CANNOT be filled in.",!!
+12 QUIT
+13 ;
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
