DGPMVODS.m

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 ---DGPMVODS   1582     printed  Apr 09, 2024@22:02:15                                                                                                                                                                                                    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