DGPMVODS ;ALB/MIR - ODS TRANSACTIONS FOR ADMIT AND DISCHARGE ; 16 JAN 91
;;5.3;Registration;;Aug 13, 1993
;;VERSION
;
;
NEW ;Determine if ODS software is on and, if so, make sure period of service is defined
;
D ON^DGYZODS S DGODSON=DGODS I 'DGODS Q
I $D(^DPT(DFN,.32)),$D(^DIC(21,+$P(^(.32),"^",3),0)) Q
W !!,"Entry of Eligibility Code and Period of Service is required to continue.",!
S DIE="^DPT(",DA=DFN
S DR=".361;.323;D ^DGYZODS;S:'DGODS Y="""";11500.02;11500.03" D ^DIE
Q
;
;
;
ADM ;if operation desert shield admission, create an entry in the ODS ADMISSIONS file
N DA D PT^DGYZODS I 'DGODS Q
S DGSPEC=$O(^DGPM("APHY",DGPMDA,0)),DGSPEC=$S($D(^DGPM(+DGSPEC,0)):$P(^(0),"^",9),1:""),DGSPEC=$S($D(^DIC(45.7,+DGSPEC,0)):$P(^(0),"^",2),1:"")
S A1B2FL=11500.2,A1B2DT=+DGPMA D ADD^A1B2UTL S (DA,DGODSE)=+Y
S DIE="^A1B2(11500.2,",DR=".02////^S X=DGODS;.03////^S X=DGSPEC" D ^DIE
S DIE="^DGPM(",DA=DGPMDA,DR="11500.04////"_DGODSE D ^DIE
K DGSPEC,DIE Q
;
;
;
DIS ;check for displace patients...create new entry if necessary
N DIE,DA
S DGODSPT=$S($D(^DGPM(DGPMDA,"ODS")):^("ODS"),1:"") I '$P(DGODSPT,"^",5) Q
I $P(DGODSPT,"^",7) Q ;Q if already stored in file
D PT1^DGYZODS I 'DGODS Q
S A1B2FL=11500.3,A1B2DT=+DGPMA I 'A1B2DT Q
D ADD^A1B2UTL S (DA,DGODSE)=+Y
S DIE="^A1B2(11500.3,",DR=".02////^S X=DGODS;.03////^S X=$P(DGODSPT,""^"",6);.1////^S X=$S($D(^DIC(4,+$P(DGPMA,""^"",5),0)):$P(^(0),""^"",1),1:"""");.11////^S X=$P(DGODSPT,""^"",2)" D ^DIE
S DIE="^DGPM(",DA=DGPMDA,DR="11500.07////"_DGODSE D ^DIE
K DGODSPT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMVODS 1582 printed Dec 13, 2024@02:50:29 Page 2
DGPMVODS ;ALB/MIR - ODS TRANSACTIONS FOR ADMIT AND DISCHARGE ; 16 JAN 91
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;;VERSION
+3 ;
+4 ;
NEW ;Determine if ODS software is on and, if so, make sure period of service is defined
+1 ;
+2 DO ON^DGYZODS
SET DGODSON=DGODS
IF 'DGODS
QUIT
+3 IF $DATA(^DPT(DFN,.32))
IF $DATA(^DIC(21,+$PIECE(^(.32),"^",3),0))
QUIT
+4 WRITE !!,"Entry of Eligibility Code and Period of Service is required to continue.",!
+5 SET DIE="^DPT("
SET DA=DFN
+6 SET DR=".361;.323;D ^DGYZODS;S:'DGODS Y="""";11500.02;11500.03"
DO ^DIE
+7 QUIT
+8 ;
+9 ;
+10 ;
ADM ;if operation desert shield admission, create an entry in the ODS ADMISSIONS file
+1 NEW DA
DO PT^DGYZODS
IF 'DGODS
QUIT
+2 SET DGSPEC=$ORDER(^DGPM("APHY",DGPMDA,0))
SET DGSPEC=$SELECT($DATA(^DGPM(+DGSPEC,0)):$PIECE(^(0),"^",9),1:"")
SET DGSPEC=$SELECT($DATA(^DIC(45.7,+DGSPEC,0)):$PIECE(^(0),"^",2),1:"")
+3 SET A1B2FL=11500.2
SET A1B2DT=+DGPMA
DO ADD^A1B2UTL
SET (DA,DGODSE)=+Y
+4 SET DIE="^A1B2(11500.2,"
SET DR=".02////^S X=DGODS;.03////^S X=DGSPEC"
DO ^DIE
+5 SET DIE="^DGPM("
SET DA=DGPMDA
SET DR="11500.04////"_DGODSE
DO ^DIE
+6 KILL DGSPEC,DIE
QUIT
+7 ;
+8 ;
+9 ;
DIS ;check for displace patients...create new entry if necessary
+1 NEW DIE,DA
+2 SET DGODSPT=$SELECT($DATA(^DGPM(DGPMDA,"ODS")):^("ODS"),1:"")
IF '$PIECE(DGODSPT,"^",5)
QUIT
+3 ;Q if already stored in file
IF $PIECE(DGODSPT,"^",7)
QUIT
+4 DO PT1^DGYZODS
IF 'DGODS
QUIT
+5 SET A1B2FL=11500.3
SET A1B2DT=+DGPMA
IF 'A1B2DT
QUIT
+6 DO ADD^A1B2UTL
SET (DA,DGODSE)=+Y
+7 SET DIE="^A1B2(11500.3,"
SET DR=".02////^S X=DGODS;.03////^S X=$P(DGODSPT,""^"",6);.1////^S X=$S($D(^DIC(4,+$P(DGPMA,""^"",5),0)):$P(^(0),""^"",1),1:"""");.11////^S X=$P(DGODSPT,""^"",2)"
DO ^DIE
+8 SET DIE="^DGPM("
SET DA=DGPMDA
SET DR="11500.07////"_DGODSE
DO ^DIE
+9 KILL DGODSPT
QUIT
