- 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 Jan 18, 2025@03:51:10 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