source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTRPO.m@ 1373

Last change on this file since 1373 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1DGPTRPO ;ALB/MTC - RECORD PRINT OUT (RPO); 11 FEB 91
2 ;;5.3;Registration;;Aug 13, 1993
3EN ;-- generic N15x call
4 D INIT G ENQ:DGOUT
5 D FMT G ENQ:DGOUT
6 S DIC="^DGP(45.87,",DIC(0)="L" K DO,DD D NOW^%DTC S X=% D FILE^DICN K DIC
7 G ENQ:Y<0 S (DA,DGDA)=+Y
8EDIT S DIE="^DGP(45.87,",(DR,DGDR)=$S(DGCTL="N150":"[DGPT 150]",1:"[DGPT 151]")
9 S DGPAT=$P(^DGP(45.87,DGDA,0),U,9),DGINST=$P(^DGP(45.87,DGDA,0),U,10)
10 F DGI=0:0 S DA=DGDA,DR=DGDR D ^DIE,CHKFLD Q:'DGOUT D ASK I DGOUT D DEL,ENQ G EN
11SEND S DGOUT=0,DIR(0)="Y",DIR("A")="Ok to Send "_DGCTL,DIR("B")="YES"
12 D ^DIR I $D(DIRUT)!(Y=0) D ASK G EDIT:'DGOUT I DGOUT D DEL,ENQ G EN
13 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 ******"
14 D ENQ G EN
15ENQ 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
16 Q
17 ;
18CHKFLD ;-- check data for valid entries
19 S DGOUT=0
20 I '$D(^DGP(45.87,DGDA,0)) S DGOUT=1 G CHKFLDQ
21 S DGRPO=^DGP(45.87,DGDA,0)
22 I DGCTL="N150" F DGJ=5:1:8 I $P(DGRPO,U,DGJ)="" S DGOUT=1 D CHKERR
23 I DGCTL="N151" F DGJ=5,8 I $P(DGRPO,U,DGJ)="" S DGOUT=1 D CHKERR
24 I DGCTL="N099" F DGJ=5,6,8 I $P(DGRPO,U,DGJ)="" S DGOUT=1 D CHKERR
25 I +$P(DGRPO,U,9) S DGNAME=$P(^DPT($P(DGRPO,U,9),0),U)
26CHKFLDQ ;
27 K DGRPO,DGJ
28 Q
29CHKERR ;
30 W !,"*** ",$P("^^^^SSN^ADMISSION DATE/TIME^ADMITTING FACILITY NUMBER/SUFFIX^REQUESTING FACILITY NUMBER/SUFFIX","^",DGJ)," field is empty."
31 Q
32 ;
33ASK ;-- On error in record check for re-edit
34 S DGOUT=0
35 S DIR(0)="Y",DIR("A")="Would you like to EDIT the "_DGCTL_" record",DIR("B")="YES"
36 D ^DIR
37 I $D(DIRUT)!(Y=0) S DGOUT=1
38ASKQ K DIR
39 Q
40 ;
41HDRPX W @IOF,$C(13),?18,">>> Facsimile of ",DGCTL," Transaction <<<"
42 W:DGNAME]"" !," Patient : ",DGNAME
43 W:DGFNAM]"" !,"Admitting Facility : ",DGFNAM
44 W !!?9,"'",$J(DGCTL,4),"' '",$J(DGSSN,10),"' '",$J(DGADM,10),"' '",$J(DGFAC,6),"' '",$J(DGRFAC,6),"'"
45 W !?2,"col# :"
46 W ?10,"1--4 5--------1 1--------2 2----3 3----3",!
47 W ?10," 4 5 4 5 0 1 6",!
48 W !?2,"block:"
49 W ?10," SSN Admission Admitting Requesting",!
50 W ?10," Date/Time Facility Facility",!
51 W ?10," Num/Suffix Num/Suffix",!!
52 I DGCTL="N151" W !,"For the 151 the Admission DATE/TIME and",!,"the Admitting Facility Num/Suffix CANNOT be filled in.",!!
53 Q
54 ;
55FMT ;-- select format 150/151; set trans router to PTF125
56 S DGOUT=0
57 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"
58 W @IOF D ^DIR I $D(DIRUT)!(Y="EXIT") S DGOUT=1 G FMTQ
59 S DGY=Y
60 S DGCTL=$S(DGY=150:"N150",1:"N151")
61 S VATNAME="PTF125" D ^VATRAN I VATERR S DGOUT=1 G FMTQ
62FMTQ K DGY,DIR,DIRUT Q
63 ;
64PRETRAN ;-- get mailman msg #
65 S DGOUT=0,XMSUB="PTF "_DGCTL,XMDUZ=DUZ
66 D GET^XMA2
67 I $D(XMZ),XMZ>0 G PREQ
68 W !!,"*** ERROR *** Unable to create Mail Message... Try again later." S DGOUT=1
69PREQ Q
70TRAN ;
71 K XMY D ROUTER^DGPTFTR
72 S XMDUN=$P(^VA(200,DUZ,0),U),^XMB(3.9,XMZ,2,0)="^3.92A^1^1^"_DT
73 D ENT1^XMD
74 S DIE="^DGP(45.87,",DA=DGDA,DR=".03////"_XMZ D ^DIE
75 K XMZ,DIE,DR
76 Q
77 ;
78DEL ;-- KILL ENTRY
79 S DA=DGDA,DIK="^DGP(45.87," D ^DIK
80 Q
81 ;
82INIT ;
83 D LO^DGUTL,HOME^%ZIS S DGOUT=0
84 S (DGPAT,DGINST,DGCTL,DGTADM,DGSSN,DGADM,DGFAC,DGFNAM,DGNAME)="",DGRFAC=$E($P($$SITE^VASITE,U,3)_" ",1,6)
85INITQ Q
Note: See TracBrowser for help on using the repository browser.