ACHSDA.m

ACHSDA ; IHS/ITSC/PMF - PATIENT DATA ;     [ 10/16/2001   8:16 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 ;OCAO/IHS CL

 ;VERSION;1.31;5/1/88

 ;

 I '$D(^AZOPBPP) W !!,"This Option Not Yet Available",!! H 2 G END

L0 ;

 S ACHSYAYA=U_"AZO"_"PWN"_"LK" D @ACHSYAYA K ACHSYAYA G END:'$D(DFN) ; LINE ADDED TO DO PAWNEE BENEFIT/DLW/6/30/95

 ;

L1 ;

 S DA=DFN,DIE="^AZOPBPP(",DR=".01:99" D ^DIE

 G L0

 ;

END ;

 Q

 ;

SBRS ;

 ;IHS/ITSC/PMF  1/19/01  changes in this module to comply

 ;with SAC.  the READ command in the comment is in quotes so

 ;that SAC checker does not see it.  Yes, it looks in comments

 ;K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT "R" Y:DTIME I '$T W *7 "R" Y:5 G SBRS:Y="." I '$T S (DTOUT,Y)="" Q

 K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT

 S DIR(0)="F"

 D ^DIR

 ;

 ;S:Y="" DLOUT="" S:Y="/.," (DFOUT,Y)="" S:Y="^" (DUOUT,Y)="" S:Y?1"?".E!(Y["^") (DQOUT,Y)=""

 I Y="" S DLOUT="" Q

 I Y="/.," S (DFOUT,Y)="" Q

 I Y="^" S (DUOUT,Y)=""

 I (Y?1"?".E!(Y["^")) S (DQOUT,Y)="" Q

 I Y'?1N W " Must be a number" G SBRS

 I Y<1!(Y>3) W " Must be between 1 and 3" G SBRS

 Q

 ;

ADD ;ADD A NEW PATIENT TO THE PB FILE

 ;IHS/ITSC/PMF  1/8/01  replace this old fashioned call with

 ;a call to the approved routine  {D AUCLS}

 ;clear the screen

 D ^XBCLS

 ;

A ;

 ;IHS/ITSC/PMF  1/9/01  change call from old routine to new

 ;but identical ^XB routine.  also, any more than three dots

 ;in row is gratuitous

 ;W !!,"ADDING a patient to the PAWNEE BENEFIT package files.....",!!! {D AUALLLK} G END:'$D(DFN)

 W !!,"ADDING a patient to the PAWNEE BENEFIT package files...",!!! D ^XBALLLK G END:'$D(DFN)

 ;

A1 ;

 I $D(^AZOPBPP(DFN)) W !!,*7,"This patient is already enrolled in the Benefit Package.",!!,"BENEFIT PACKAGE NUMBER: ",$P($G(^(DFN,0)),U,2),!! G A

A2 ;

 ;IHS/ITSC/PMF  1/10/01  split next line and replace naked refs

 ;G B:$D(^AUPNPAT(DFN,41,2564))!$D(^(2565))!$D(^(2566)) W !!,*7,"The patient must be registered at Pawnee, Pawhuska, or White Eagle",!,"before he/she can be added to the Benefit Package file.",!! G A

 G B:$D(^AUPNPAT(DFN,41,2564))!$D(^AUPNPAT(DFN,41,2565))!$D(^AUPNPAT(DFN,41,2566))

 W !!,*7,"The patient must be registered at Pawnee, Pawhuska, or White Eagle",!,"before he/she can be added to the Benefit Package file.",!! G A

 ;

B ;

 W !! S DIE="^AZOPBPP(",DA=DFN,DR=".01:99",^AZOPBPP(DFN,0)=DFN,^AZOPBPP("B",DFN,DFN)="",$P(^AZOPBPP(0),U,3)=DFN,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 D ^DIE

 ;

C ;CHECK FOR BEN. PACK. NUMBER

C1 ;

 I $D(^AZOPBPP(DFN,0)),$P(^AZOPBPP(DFN,0),"^",2)']"" S DR=".01///@" D ^DIE W !!,*7,"File deleted - no Benefit Package number.",!! G A

 G END

TEMP ;ADD NEW PATIENT WITH TEMPORART CHART NUMBER

 W !!,"At which facility will this patient be registered?",!!?10,"1...Pawnee",!?10,"2...White Eagle",!?10,"3...Pawhuska",!!,?10 D SBRS Q:$D(DTOUT)!$D(DFOUT)!$D(DUOUT)!$D(DLOUT)

QUES I $D(DQOUT) W !!,"Choose the facility in which this patient will receive his primary care.",!! G TEMP

 S Y=+Y I Y<1!(Y>3) S DQOUT="" G QUES

 S ^ACHS("ASITE")=ASITE,ASITE=$S(Y=3:2564,Y=2:2565,1:2566)

 S DOG="" D DOG^AG0 D L2^AG2:$D(DFN) K DFN,DOG,%DT S ASITE=$G(^ACHS("ASITE")) K ^ACHS("ASITE") G END

ACHSDA    ; IHS/ITSC/PMF - PATIENT DATA ;     [ 10/16/2001   8:16 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 +2       ;OCAO/IHS CL

 +3       ;VERSION;1.31;5/1/88

 +4       ;

 +5        IF '$DATA(^AZOPBPP)

               WRITE !!,"This Option Not Yet Available",!!

               HANG 2

               GOTO END

L0        ;

 +1       ; LINE ADDED TO DO PAWNEE BENEFIT/DLW/6/30/95

           SET ACHSYAYA=U_"AZO"_"PWN"_"LK"

           DO @ACHSYAYA

           KILL ACHSYAYA

           IF '$DATA(DFN)

               GOTO END

 +2       ;

L1        ;

 +1        SET DA=DFN

           SET DIE="^AZOPBPP("

           SET DR=".01:99"

           DO ^DIE

 +2        GOTO L0

 +3       ;

END       ;

 +1        QUIT 

 +2       ;

SBRS      ;

 +1       ;IHS/ITSC/PMF  1/19/01  changes in this module to comply

 +2       ;with SAC.  the READ command in the comment is in quotes so

 +3       ;that SAC checker does not see it.  Yes, it looks in comments

 +4       ;K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT "R" Y:DTIME I '$T W *7 "R" Y:5 G SBRS:Y="." I '$T S (DTOUT,Y)="" Q

 +5        KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT

 +6        SET DIR(0)="F"

 +7        DO ^DIR

 +8       ;

 +9       ;S:Y="" DLOUT="" S:Y="/.," (DFOUT,Y)="" S:Y="^" (DUOUT,Y)="" S:Y?1"?".E!(Y["^") (DQOUT,Y)=""

 +10       IF Y=""

               SET DLOUT=""

               QUIT 

 +11       IF Y="/.,"

               SET (DFOUT,Y)=""

               QUIT 

 +12       IF Y="^"

               SET (DUOUT,Y)=""

 +13       IF (Y?1"?".E!(Y["^"))

               SET (DQOUT,Y)=""

               QUIT 

 +14       IF Y'?1N

               WRITE " Must be a number"

               GOTO SBRS

 +15       IF Y<1!(Y>3)

               WRITE " Must be between 1 and 3"

               GOTO SBRS

 +16       QUIT 

 +17      ;

ADD       ;ADD A NEW PATIENT TO THE PB FILE

 +1       ;IHS/ITSC/PMF  1/8/01  replace this old fashioned call with

 +2       ;a call to the approved routine  {D AUCLS}

 +3       ;clear the screen

 +4        DO ^XBCLS

 +5       ;

A         ;

 +1       ;IHS/ITSC/PMF  1/9/01  change call from old routine to new

 +2       ;but identical ^XB routine.  also, any more than three dots

 +3       ;in row is gratuitous

 +4       ;W !!,"ADDING a patient to the PAWNEE BENEFIT package files.....",!!! {D AUALLLK} G END:'$D(DFN)

 +5        WRITE !!,"ADDING a patient to the PAWNEE BENEFIT package files...",!!!

           DO ^XBALLLK

           IF '$DATA(DFN)

               GOTO END

 +6       ;

A1        ;

 +1        IF $DATA(^AZOPBPP(DFN))

               WRITE !!,*7,"This patient is already enrolled in the Benefit Package.",!!,"BENEFIT PACKAGE NUMBER: ",$PIECE($GET(^(DFN,0)),U,2),!!

               GOTO A

A2        ;

 +1       ;IHS/ITSC/PMF  1/10/01  split next line and replace naked refs

 +2       ;G B:$D(^AUPNPAT(DFN,41,2564))!$D(^(2565))!$D(^(2566)) W !!,*7,"The patient must be registered at Pawnee, Pawhuska, or White Eagle",!,"before he/she can be added to the Benefit Package file.",!! G A

 +3        IF $DATA(^AUPNPAT(DFN,41,2564))!$DATA(^AUPNPAT(DFN,41,2565))!$DATA(^AUPNPAT(DFN,41,2566))

               GOTO B

 +4        WRITE !!,*7,"The patient must be registered at Pawnee, Pawhuska, or White Eagle",!,"before he/she can be added to the Benefit Package file.",!!

           GOTO A

 +5       ;

B         ;

 +1        WRITE !!

           SET DIE="^AZOPBPP("

           SET DA=DFN

           SET DR=".01:99"

           SET ^AZOPBPP(DFN,0)=DFN

           SET ^AZOPBPP("B",DFN,DFN)=""

           SET $PIECE(^AZOPBPP(0),U,3)=DFN

           SET $PIECE(^(0),"^",4)=+$PIECE(^(0),"^",4)+1

           DO ^DIE

 +2       ;

C         ;CHECK FOR BEN. PACK. NUMBER

C1        ;

 +1        IF $DATA(^AZOPBPP(DFN,0))

               IF $PIECE(^AZOPBPP(DFN,0),"^",2)']""

                   SET DR=".01///@"

                   DO ^DIE

                   WRITE !!,*7,"File deleted - no Benefit Package number.",!!

                   GOTO A

 +2        GOTO END

TEMP      ;ADD NEW PATIENT WITH TEMPORART CHART NUMBER

 +1        WRITE !!,"At which facility will this patient be registered?",!!?10,"1...Pawnee",!?10,"2...White Eagle",!?10,"3...Pawhuska",!!,?10

           DO SBRS

           IF $DATA(DTOUT)!$DATA(DFOUT)!$DATA(DUOUT)!$DATA(DLOUT)

               QUIT 

QUES       IF $DATA(DQOUT)

               WRITE !!,"Choose the facility in which this patient will receive his primary care.",!!

               GOTO TEMP

 +1        SET Y=+Y

           IF Y<1!(Y>3)

               SET DQOUT=""

               GOTO QUES

 +2        SET ^ACHS("ASITE")=ASITE

           SET ASITE=$SELECT(Y=3:2564,Y=2:2565,1:2566)

 +3        SET DOG=""

           DO DOG^AG0

           IF $DATA(DFN)

               DO L2^AG2

           KILL DFN,DOG,%DT

           SET ASITE=$GET(^ACHS("ASITE"))

           KILL ^ACHS("ASITE")

           GOTO END