APSQPMI.m

APSQPMI ;IHS/ASDS/ENM/POC - PRINTS THE PATIENT MEDICATION SHEETS ;09-Oct-2008 11:27;SM

 ;;7.0;IHS PHARMACY MODIFICATIONS;**1007**;Sep 23, 2004

 ; Modified - IHS/CIA/PLS - 01/21/04

 ;            IHS/MSC/PLS - 08/19/08 - Line EN1+8

EN ;EP - NORMAL ENTRY POINT

 S PSNDFN=DFN

 I ('$D(APSPCPP))!($G(APSPCPP)=ION) G PMI

TSK F I="PPL","APSPCPP","PSNDFN" S ZTSAVE(I)=""

 S ZTRTN="PMI^APSQPMI"

 S ZTDESC="PRINTS PATIENT MED SHEETS"

 S ZTDTH=$H

 S ZTIO=APSPCPP

 S ZTREQ="@"

 D ^%ZTLOAD

 Q

 ;

EN1 ;ENTRY FROM PATIENT NAME

 N PPL,PSOSD,DFN,APSQRXN,APSQIEN,APSQDRG,APSQ

 N PSRX,PSNDFN,NAM,APSDNAM,APSDOC,APSPNDC,CR,DFN,ED,ED1,ED2,ED3,NDC,NUM

 N P2,PG,PPI,PPL,PS,PSODFN,SSN,SEX,VA,VADM,XNDC

 N Z,PSCNT,PSOCT,PSODTCUT,PSOERR,PSOLIST,PSOOPT,PSOSTA,RXN,STP,STR

 N J,JJ,IEN,DIWI,DIW,DIWT,DN,APSPIRN,APSPZDT

 N POP,VAERR,CNT,DIR,DIWTC,DOB,DRG,IOHG,DIWX,IOBS

 D PAT^APSPNUM   ;IHS/CIA/PLS - 01/21/04

 Q:'$D(PSODFN)  ; IHS/MSC/PLS - 08/19/08

 S PSONUM="LIST"

 D EN^APSPNUM

 G:'$D(PSOLIST) END

 S PPL=PSOLIST(1) ;BETTER WATCH THIS AS IT CAN BE TOO LONG

 G EN

 ;

PMI ;SET UP AND PRINT

 I $E(IOST)="P" S APSQCOM=$P($G(^%ZIS(2,IOST(0),12.1)),"^"),APSQRSET=$P($G(^(6)),"^") W:APSQCOM]"" @APSQCOM ;COMPRESS IF A PRINTER TO 16 PITCH

 Q:'$D(PPL)  ;NO RXS TO PRINT SO NO MED SHEETS TO PRINT EITHER

 F I=1:1 S APSQIEN=$P(PPL,",",I) Q:'APSQIEN  D

 .S APSQDRG=$P(^PSRX(APSQIEN,0),"^",6)

 .Q:$$TEST(APSQDRG)

 .S APSQRXN=+^PSRX(APSQIEN,0)

 .S PPI=^PSDRUG(APSQDRG,"ND")

 .S PPI=$P(^PSNDF(+PPI,5,$P(PPI,"^",3),0),"^",7)

 .S APSQ(I)=PPI_"^"_APSQDRG_"^"_APSQRXN ;SO ONLY GET ONE OF SHEET EVEN IF TWO DRUGS POINT TO SAME PATIENT INFORMATION SHEET

 .Q

 S TYPE=$S($G(APSQTYPE):APSQTYPE,1:2) ;IHS/OKCAO/POC APSQTYPE IS IN APSPCONTROL FILE FIELD 301

 S NUM=1

PRINT S JJ=0 F  S JJ=$O(APSQ(JJ)) Q:'JJ  S PPI=+APSQ(JJ),DRG=$P(APSQ(JJ),"^",2),PSRX=$P(APSQ(JJ),"^",3) D DOONE^PSNPPIP

END Q

TEST(N) ;TEST FOR ENTRY OF PATIENT MED SHEET IN ^PSPPI GLOBAL

 N TEST S TEST=$G(^PSDRUG(N,"ND"))

 S TEST=$P($G(^PSNDF(+TEST,5,+$P(TEST,"^",3),0)),"^",7)

 I TEST,$D(^PSPPI(+TEST)),$S('$G(^PSDRUG(+N,"I")):1,DT'>^("I"):1,1:0) Q 0

 E  Q 1 ;1=NO GO

APSQPMI   ;IHS/ASDS/ENM/POC - PRINTS THE PATIENT MEDICATION SHEETS ;09-Oct-2008 11:27;SM

 +1       ;;7.0;IHS PHARMACY MODIFICATIONS;**1007**;Sep 23, 2004

 +2       ; Modified - IHS/CIA/PLS - 01/21/04

 +3       ;            IHS/MSC/PLS - 08/19/08 - Line EN1+8

EN        ;EP - NORMAL ENTRY POINT

 +1        SET PSNDFN=DFN

 +2        IF ('$DATA(APSPCPP))!($GET(APSPCPP)=ION)

               GOTO PMI

TSK        FOR I="PPL","APSPCPP","PSNDFN"

               SET ZTSAVE(I)=""

 +1        SET ZTRTN="PMI^APSQPMI"

 +2        SET ZTDESC="PRINTS PATIENT MED SHEETS"

 +3        SET ZTDTH=$HOROLOG

 +4        SET ZTIO=APSPCPP

 +5        SET ZTREQ="@"

 +6        DO ^%ZTLOAD

 +7        QUIT 

 +8       ;

EN1       ;ENTRY FROM PATIENT NAME

 +1        NEW PPL,PSOSD,DFN,APSQRXN,APSQIEN,APSQDRG,APSQ

 +2        NEW PSRX,PSNDFN,NAM,APSDNAM,APSDOC,APSPNDC,CR,DFN,ED,ED1,ED2,ED3,NDC,NUM

 +3        NEW P2,PG,PPI,PPL,PS,PSODFN,SSN,SEX,VA,VADM,XNDC

 +4        NEW Z,PSCNT,PSOCT,PSODTCUT,PSOERR,PSOLIST,PSOOPT,PSOSTA,RXN,STP,STR

 +5        NEW J,JJ,IEN,DIWI,DIW,DIWT,DN,APSPIRN,APSPZDT

 +6        NEW POP,VAERR,CNT,DIR,DIWTC,DOB,DRG,IOHG,DIWX,IOBS

 +7       ;IHS/CIA/PLS - 01/21/04

           DO PAT^APSPNUM

 +8       ; IHS/MSC/PLS - 08/19/08

           IF '$DATA(PSODFN)

               QUIT 

 +9        SET PSONUM="LIST"

 +10       DO EN^APSPNUM

 +11       IF '$DATA(PSOLIST)

               GOTO END

 +12      ;BETTER WATCH THIS AS IT CAN BE TOO LONG

           SET PPL=PSOLIST(1)

 +13       GOTO EN

 +14      ;

PMI       ;SET UP AND PRINT

 +1       ;COMPRESS IF A PRINTER TO 16 PITCH

           IF $EXTRACT(IOST)="P"

               SET APSQCOM=$PIECE($GET(^%ZIS(2,IOST(0),12.1)),"^")

               SET APSQRSET=$PIECE($GET(^(6)),"^")

               IF APSQCOM]""

                   WRITE @APSQCOM

 +2       ;NO RXS TO PRINT SO NO MED SHEETS TO PRINT EITHER

           IF '$DATA(PPL)

               QUIT 

 +3        FOR I=1:1

               SET APSQIEN=$PIECE(PPL,",",I)

               IF 'APSQIEN

                   QUIT 

               Begin DoDot:1

 +4                SET APSQDRG=$PIECE(^PSRX(APSQIEN,0),"^",6)

 +5                IF $$TEST(APSQDRG)

                       QUIT 

 +6                SET APSQRXN=+^PSRX(APSQIEN,0)

 +7                SET PPI=^PSDRUG(APSQDRG,"ND")

 +8                SET PPI=$PIECE(^PSNDF(+PPI,5,$PIECE(PPI,"^",3),0),"^",7)

 +9       ;SO ONLY GET ONE OF SHEET EVEN IF TWO DRUGS POINT TO SAME PATIENT INFORMATION SHEET

                   SET APSQ(I)=PPI_"^"_APSQDRG_"^"_APSQRXN

 +10               QUIT 

               End DoDot:1

 +11      ;IHS/OKCAO/POC APSQTYPE IS IN APSPCONTROL FILE FIELD 301

           SET TYPE=$SELECT($GET(APSQTYPE):APSQTYPE,1:2)

 +12       SET NUM=1

PRINT      SET JJ=0

           FOR 

               SET JJ=$ORDER(APSQ(JJ))

               IF 'JJ

                   QUIT 

               SET PPI=+APSQ(JJ)

               SET DRG=$PIECE(APSQ(JJ),"^",2)

               SET PSRX=$PIECE(APSQ(JJ),"^",3)

               DO DOONE^PSNPPIP

END        QUIT 

TEST(N)   ;TEST FOR ENTRY OF PATIENT MED SHEET IN ^PSPPI GLOBAL

 +1        NEW TEST

           SET TEST=$GET(^PSDRUG(N,"ND"))

 +2        SET TEST=$PIECE($GET(^PSNDF(+TEST,5,+$PIECE(TEST,"^",3),0)),"^",7)

 +3        IF TEST

               IF $DATA(^PSPPI(+TEST))

                   IF $SELECT('$GET(^PSDRUG(+N,"I")):1,DT'>^("I"):1,1:0)

                       QUIT 0

 +4       ;1=NO GO

          IF '$TEST

               QUIT 1