AMHPPLK.m

AMHPPLK ; IHS/CMI/LAB - LOOKUP PCC PROBLEM ;

 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 ;CALLED FROM AMH INPUT TEMPLATES

 ; Problem based on a problem # that is entered through data entry.

 S U="^",AMHPERR=""

 I AMHPR="?" W !,"Enter a Problem Number in the form XXXXNN, where XXXX is the 2-4 digit location",!," abbreviation and NN is a problem number from 1 to 999.99." S AMHPERR=1 Q

 I AMHPR="??" W !,"Enter a Problem number in the form XXXXNN where XXXX is the 2-4 digit location",!," abbreviation and NN is problem number.  The available loc. abbrevs are:" D LL S AMHPERR=1 Q

 S:AMHPR["#" AMHPR=$P(AMHPR,"#")_$P(AMHPR,"#",2)

 S AMHPPL="" F AMHPI=1:1:$L(AMHPR) Q:$E(AMHPR,AMHPI)?1N  S AMHPPL=AMHPPL_$E(AMHPR,AMHPI)

 I AMHPPL="" W !,"No facility code has been entered." S AMHPERR=1 Q

 S AMHPLOC="",AMHPLOC=$O(^AUTTLOC("D",AMHPPL,AMHPLOC)) I AMHPLOC="" W !,"NO Location Abbreviation - PLEASE NOTIFY YOUR SUPERVISOR" S AMHPERR=1 Q

 S AMHPN=$P(AMHPR,AMHPPL,2) I AMHPN<1!(AMHPN>999.99) W !,"Invalid problem number" S AMHPERR=1 Q

 S AMHPN=" "_$E("000",1,(3-$L($P(AMHPN,"."))))_$P(AMHPN,".")_"."_$P(AMHPN,".",2)_$E("00",1,(2-$L($P(AMHPN,".",2))))

 I '$D(^AUPNPROB("AA",AMHPAT,AMHPLOC,AMHPN)) W !,"No Problem Number ",AMHPN," on file for this patient for location ",$P(^AUTTLOC(AMHPLOC,0),U,2),"." S AMHPERR=1 Q

 S AMHPDFN="",AMHPDFN=$O(^AUPNPROB("AA",AMHPAT,AMHPLOC,AMHPN,AMHPDFN))

 S AMHPDFN="`"_AMHPDFN

 K AMHPLOC,AMHPN,AMHPI,AMHPN,AMHPPL,AMHPL,AMHPSUB

 Q

LL ;

 N DIC,DA,D,DZ S DIC="^AUTTLOC(",DIC(0)="E",D="D",DZ="??" D DQ^DICQ K Y,DIC,D

 Q

AMHPPLK   ; IHS/CMI/LAB - LOOKUP PCC PROBLEM ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 +2       ;CALLED FROM AMH INPUT TEMPLATES

 +3       ; Problem based on a problem # that is entered through data entry.

 +4        SET U="^"

           SET AMHPERR=""

 +5        IF AMHPR="?"

               WRITE !,"Enter a Problem Number in the form XXXXNN, where XXXX is the 2-4 digit location",!," abbreviation and NN is a problem number from 1 to 999.99."

               SET AMHPERR=1

               QUIT 

 +6        IF AMHPR="??"

               WRITE !,"Enter a Problem number in the form XXXXNN where XXXX is the 2-4 digit location",!," abbreviation and NN is problem number.  The available loc. abbrevs are:"

               DO LL

               SET AMHPERR=1

               QUIT 

 +7        IF AMHPR["#"

               SET AMHPR=$PIECE(AMHPR,"#")_$PIECE(AMHPR,"#",2)

 +8        SET AMHPPL=""

           FOR AMHPI=1:1:$LENGTH(AMHPR)

               IF $EXTRACT(AMHPR,AMHPI)?1N

                   QUIT 

               SET AMHPPL=AMHPPL_$EXTRACT(AMHPR,AMHPI)

 +9        IF AMHPPL=""

               WRITE !,"No facility code has been entered."

               SET AMHPERR=1

               QUIT 

 +10       SET AMHPLOC=""

           SET AMHPLOC=$ORDER(^AUTTLOC("D",AMHPPL,AMHPLOC))

           IF AMHPLOC=""

               WRITE !,"NO Location Abbreviation - PLEASE NOTIFY YOUR SUPERVISOR"

               SET AMHPERR=1

               QUIT 

 +11       SET AMHPN=$PIECE(AMHPR,AMHPPL,2)

           IF AMHPN<1!(AMHPN>999.99)

               WRITE !,"Invalid problem number"

               SET AMHPERR=1

               QUIT 

 +12       SET AMHPN=" "_$EXTRACT("000",1,(3-$LENGTH($PIECE(AMHPN,"."))))_$PIECE(AMHPN,".")_"."_$PIECE(AMHPN,".",2)_$EXTRACT("00",1,(2-$LENGTH($PIECE(AMHPN,".",2))))

 +13       IF '$DATA(^AUPNPROB("AA",AMHPAT,AMHPLOC,AMHPN))

               WRITE !,"No Problem Number ",AMHPN," on file for this patient for location ",$PIECE(^AUTTLOC(AMHPLOC,0),U,2),"."

               SET AMHPERR=1

               QUIT 

 +14       SET AMHPDFN=""

           SET AMHPDFN=$ORDER(^AUPNPROB("AA",AMHPAT,AMHPLOC,AMHPN,AMHPDFN))

 +15       SET AMHPDFN="`"_AMHPDFN

 +16       KILL AMHPLOC,AMHPN,AMHPI,AMHPN,AMHPPL,AMHPL,AMHPSUB

 +17       QUIT 

LL        ;

 +1        NEW DIC,DA,D,DZ

           SET DIC="^AUTTLOC("

           SET DIC(0)="E"

           SET D="D"

           SET DZ="??"

           DO DQ^DICQ

           KILL Y,DIC,D

 +2        QUIT