Routine: GMTSPSO

GMTSPSO ;SLC/JER,KER/NDBI - OP Rx Summary Component (V6) ;Apr 16, 2021@16:16:52

 ;;2.7;Health Summary;**15,28,37,56,78,80,115**;Oct 20, 1995;Build 190

 ; External References

 ;   DBIA  10141  $$VERSION^XPDUTL

 ;   DBIA   2931  HS^A7RPSOHS

 ;   DBIA   2931  HS^A7RPSOHS

 ;   DBIA    330  ^PSOHCSUM, ACS^PSOHCSUM

 ;   DBIA    522  ^PS(55,

 ;   DBIA  10035  ^DPT(  file #2

 ;   DBIA   3136  ^PS(59.7,

 ;   DBIA   4820  ^PSO52API

MAIN ; OP Rx HS Comp

 ;   Check for version 7 (or greater)   MAIN^GMTSPSO7

 I $$VERSION^XPDUTL("PSO")'<7 G MAIN^GMTSPSO7

 ;   If not version 7                   MAIN^GMTSPSO

 N ECD,GMR,IX,PSOBEGIN,PSOACT,GMX,GMTOP

 S PSOBEGIN=$S(GMTS2'=9999999:(9999999-GMTS2),1:"")

 I PSOBEGIN="" S PSOACT=1 K PSOBEGIN

 K ^TMP("PSOO",$J),^TMP($J,"GMTSPS")

 D PROF^PSO52API(DFN,"GMTSPS",1,9999999)

 D:$$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU) HS^A7RPSOHS(DFN)

 I +$G(^TMP($J,"GMTSPS",DFN,0))<1,'$D(^TMP($J,"GMTSPS",DFN,"ARC")) Q

 I '$G(^TMP($J,"GMTSPS",DFN,0)),$D(^TMP($J,"GMTSPS",DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT)  W "Patient Has Archived OP Prescriptions",!

 ;I '$D(^PS(55,DFN,"P")),'$D(^("ARC")),'$D(^TMP("PSOO",$J)) Q

 ;I '$O(^PS(55,DFN,"P",0)),$D(^PS(55,DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT)  W "Patient Has Archived OP Prescriptions",!

 I $L($T(ACS^PSOHCSUM))>0 D ACS^PSOHCSUM D:$$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU) HS^A7RPSOHS(DFN) I '$D(^TMP("PSOO",$J)) Q

 I $L($T(ACS^PSOHCSUM))'>0 D ^PSOHCSUM D:$$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU) HS^A7RPSOHS(DFN) I '$D(^TMP("PSOO",$J)) Q

 S GMTSLO=GMTSLO+3

 S (GMX,GMTOP,IX)=0

 F  S IX=$O(^TMP("PSOO",$J,IX)) Q:IX'>0  S GMR=$G(^(IX,0)) D WRT

 S GMTSLO=GMTSLO-3

 K ^TMP("PSOO",$J)

WRT ; Writes OP Pharmacy Segment Record

 N ID,LFD,X,MI,NL,CF,GMD,GMV,GMI,GUI,IND S GUI=$$HF^GMTSU

 S ID=$P(GMR,U),LFD=$P(GMR,U,2),ECD=$P(GMR,U,11),CF=$P(GMR,U,10)

 ;   Don't display when issue date is after To Date

 Q:+$G(GMRANGE)&(ID>(9999999-GMTS1))

 F GMV="ID","LFD","ECD" S X=@GMV D REGDT4^GMTSU S @GMV=X K X

 S MI=$G(^TMP("PSOO",$J,IX,1)),NL=0 I $L(MI)>73 D PARSE

 S IND=$P($G(^TMP("PSOO",$J,IX,"IND")),U)

 S GMD=$P($P(GMR,U,4),";",2)

 D CKP^GMTSUP Q:$D(GMTSQIT)

 D:GMTSNPG!(GMX'>0) HEAD W:'GMTOP ! S GMTOP=0 W $P($P(GMR,U,3),";",2)

 W !,?18,$P(GMR,U,6),?31,$S($P($P(GMR,U,5),";")="S":"ACTIVE/SUSP",1:$P($P(GMR,U,5),";",2)),?45,$P(GMR,U,7),?54,ID,?65,LFD,?76,"("_$P(GMR,U,8)_")",!

 S GMX=1 I 'NL D CKP^GMTSUP Q:$D(GMTSQIT)  D:GMTSNPG HEAD W ?2,"SIG: ",MI,! S GMTOP=0

 F GMI=1:1:NL D CKP^GMTSUP Q:$D(GMTSQIT)  D:GMTSNPG HEAD W:GMI=1 ?2,"SIG: " W ?7,MI(GMI),! S GMTOP=0

 D CKP^GMTSUP Q:$D(GMTSQIT)  D:GMTSNPG HEAD W:IND]"" ?4,"Indication: "_IND,! W ?4,"Provider: ",$E(GMD,1,22) W:CF ?37,"Cost/Fill: $",$J(CF,6,2)

 I "EC"[$P($P(GMR,U,5),";"),ECD]"" W ?57,"Exp/Can Dt: "_ECD

 W ! S GMTOP=0

PARSE ; Parses Medication Instructions

 N GMI,NW,WPL

 S NL=$S(($L(MI)/73)>($L(MI)\73):($L(MI)\73)+1,1:$L(MI)\73)

 S NW=$L(MI," "),WPL=$S((NW/NL)>(NW\NL):(NW\NL)+1,1:NW\NL)

 F GMI=1:1:NL S MI(GMI)=$P(MI," ",(GMI-1)*WPL+1,GMI*WPL)

HEAD ; Prints Header

 S GMTOP=1

 K ^TMP($J,"GMTSPSSYS") D PSS^PSS59P7(1,,"GMTSPSSYS")

 I GMX'>0,$D(^DPT(DFN,.1)),^(.1)]"",+$G(^TMP($J,"GMTSPSSYS",1,40.1)) D CKP^GMTSUP Q:$D(GMTSQIT)  W "Outpatient prescriptions are cancelled 72 hours after admission",!

 ;I GMX'>0,$D(^DPT(DFN,.1)),^(.1)]"",+($P($G(^PS(59.7,1,40.1)),"^")) D CKP^GMTSUP Q:$D(GMTSQIT)  W "Outpatient prescriptions are cancelled 72 hours after admission",!

 D CKP^GMTSUP Q:$D(GMTSQIT)  W !,"Drug....................................",?65,"Last",!

 D CKP^GMTSUP Q:$D(GMTSQIT)

 W ?18,"Rx #",?31,"Stat",?45,"Qty",?54,"Issued",?65,"Filled",?76,"Rem"

 W:$Y'>(IOSL-GMTSLO)!(+($G(GUI))>0) !

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSPSO   3695     printed  Mar 13, 2025@21:04:23                                                                                                                                                                                                     Page 2

GMTSPSO   ;SLC/JER,KER/NDBI - OP Rx Summary Component (V6) ;Apr 16, 2021@16:16:52

 +1       ;;2.7;Health Summary;**15,28,37,56,78,80,115**;Oct 20, 1995;Build 190

 +2       ;

 +3       ; External References

 +4       ;   DBIA  10141  $$VERSION^XPDUTL

 +5       ;   DBIA   2931  HS^A7RPSOHS

 +6       ;   DBIA   2931  HS^A7RPSOHS

 +7       ;   DBIA    330  ^PSOHCSUM, ACS^PSOHCSUM

 +8       ;   DBIA    522  ^PS(55,

 +9       ;   DBIA  10035  ^DPT(  file #2

 +10      ;   DBIA   3136  ^PS(59.7,

 +11      ;   DBIA   4820  ^PSO52API

 +12      ;

MAIN      ; OP Rx HS Comp

 +1       ;   Check for version 7 (or greater)   MAIN^GMTSPSO7

 +2        IF $$VERSION^XPDUTL("PSO")'<7

               GOTO MAIN^GMTSPSO7

 +3       ;   If not version 7                   MAIN^GMTSPSO

 +4        NEW ECD,GMR,IX,PSOBEGIN,PSOACT,GMX,GMTOP

 +5        SET PSOBEGIN=$SELECT(GMTS2'=9999999:(9999999-GMTS2),1:"")

 +6        IF PSOBEGIN=""

               SET PSOACT=1

               KILL PSOBEGIN

 +7        KILL ^TMP("PSOO",$JOB),^TMP($JOB,"GMTSPS")

 +8        DO PROF^PSO52API(DFN,"GMTSPS",1,9999999)

 +9        if $$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU)

               DO HS^A7RPSOHS(DFN)

 +10       IF +$GET(^TMP($JOB,"GMTSPS",DFN,0))<1

               IF '$DATA(^TMP($JOB,"GMTSPS",DFN,"ARC"))

                   QUIT

 +11       IF '$GET(^TMP($JOB,"GMTSPS",DFN,0))

               IF $DATA(^TMP($JOB,"GMTSPS",DFN,"ARC"))

                   DO CKP^GMTSUP

                   if $DATA(GMTSQIT)

                       QUIT

                   WRITE "Patient Has Archived OP Prescriptions",!

 +12      ;I '$D(^PS(55,DFN,"P")),'$D(^("ARC")),'$D(^TMP("PSOO",$J)) Q

 +13      ;I '$O(^PS(55,DFN,"P",0)),$D(^PS(55,DFN,"ARC")) D CKP^GMTSUP Q:$D(GMTSQIT)  W "Patient Has Archived OP Prescriptions",!

 +14       IF $LENGTH($TEXT(ACS^PSOHCSUM))>0

               DO ACS^PSOHCSUM

               if $$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU)

                   DO HS^A7RPSOHS(DFN)

               IF '$DATA(^TMP("PSOO",$JOB))

                   QUIT

 +15       IF $LENGTH($TEXT(ACS^PSOHCSUM))'>0

               DO ^PSOHCSUM

               if $$ROK^GMTSU("A7RPSOHS")&($$NDBI^GMTSU)

                   DO HS^A7RPSOHS(DFN)

               IF '$DATA(^TMP("PSOO",$JOB))

                   QUIT

 +16       SET GMTSLO=GMTSLO+3

 +17       SET (GMX,GMTOP,IX)=0

 +18       FOR

               SET IX=$ORDER(^TMP("PSOO",$JOB,IX))

               if IX'>0

                   QUIT

               SET GMR=$GET(^(IX,0))

               DO WRT

 +19       SET GMTSLO=GMTSLO-3

 +20       KILL ^TMP("PSOO",$JOB)

 +21       QUIT

WRT       ; Writes OP Pharmacy Segment Record

 +1        NEW ID,LFD,X,MI,NL,CF,GMD,GMV,GMI,GUI,IND

           SET GUI=$$HF^GMTSU

 +2        SET ID=$PIECE(GMR,U)

           SET LFD=$PIECE(GMR,U,2)

           SET ECD=$PIECE(GMR,U,11)

           SET CF=$PIECE(GMR,U,10)

 +3       ;   Don't display when issue date is after To Date

 +4        if +$GET(GMRANGE)&(ID>(9999999-GMTS1))

               QUIT

 +5        FOR GMV="ID","LFD","ECD"

               SET X=@GMV

               DO REGDT4^GMTSU

               SET @GMV=X

               KILL X

 +6        SET MI=$GET(^TMP("PSOO",$JOB,IX,1))

           SET NL=0

           IF $LENGTH(MI)>73

               DO PARSE

 +7        SET IND=$PIECE($GET(^TMP("PSOO",$JOB,IX,"IND")),U)

 +8        SET GMD=$PIECE($PIECE(GMR,U,4),";",2)

 +9        DO CKP^GMTSUP

           if $DATA(GMTSQIT)

               QUIT

 +10       if GMTSNPG!(GMX'>0)

               DO HEAD

           if 'GMTOP

               WRITE !

           SET GMTOP=0

           WRITE $PIECE($PIECE(GMR,U,3),";",2)

 +11       WRITE !,?18,$PIECE(GMR,U,6),?31,$SELECT($PIECE($PIECE(GMR,U,5),";")="S":"ACTIVE/SUSP",1:$PIECE($PIECE(GMR,U,5),";",2)),?45,$PIECE(GMR,U,7),?54,ID,?65,LFD,?76,"("_$PIECE(GMR,U,8)_")",!

 +12       SET GMX=1

           IF 'NL

               DO CKP^GMTSUP

               if $DATA(GMTSQIT)

                   QUIT

               if GMTSNPG

                   DO HEAD

               WRITE ?2,"SIG: ",MI,!

               SET GMTOP=0

 +13       FOR GMI=1:1:NL

               DO CKP^GMTSUP

               if $DATA(GMTSQIT)

                   QUIT

               if GMTSNPG

                   DO HEAD

               if GMI=1

                   WRITE ?2,"SIG: "

               WRITE ?7,MI(GMI),!

               SET GMTOP=0

 +14       DO CKP^GMTSUP

           if $DATA(GMTSQIT)

               QUIT

           if GMTSNPG

               DO HEAD

           if IND]""

               WRITE ?4,"Indication: "_IND,!

           WRITE ?4,"Provider: ",$EXTRACT(GMD,1,22)

           if CF

               WRITE ?37,"Cost/Fill: $",$JUSTIFY(CF,6,2)

 +15       IF "EC"[$PIECE($PIECE(GMR,U,5),";")

               IF ECD]""

                   WRITE ?57,"Exp/Can Dt: "_ECD

 +16       WRITE !

           SET GMTOP=0

 +17       QUIT

PARSE     ; Parses Medication Instructions

 +1        NEW GMI,NW,WPL

 +2        SET NL=$SELECT(($LENGTH(MI)/73)>($LENGTH(MI)\73):($LENGTH(MI)\73)+1,1:$LENGTH(MI)\73)

 +3        SET NW=$LENGTH(MI," ")

           SET WPL=$SELECT((NW/NL)>(NW\NL):(NW\NL)+1,1:NW\NL)

 +4        FOR GMI=1:1:NL

               SET MI(GMI)=$PIECE(MI," ",(GMI-1)*WPL+1,GMI*WPL)

 +5        QUIT

HEAD      ; Prints Header

 +1        SET GMTOP=1

 +2        KILL ^TMP($JOB,"GMTSPSSYS")

           DO PSS^PSS59P7(1,,"GMTSPSSYS")

 +3        IF GMX'>0

               IF $DATA(^DPT(DFN,.1))

                   IF ^(.1)]""

                       IF +$GET(^TMP($JOB,"GMTSPSSYS",1,40.1))

                           DO CKP^GMTSUP

                           if $DATA(GMTSQIT)

                               QUIT

                           WRITE "Outpatient prescriptions are cancelled 72 hours after admission",!

 +4       ;I GMX'>0,$D(^DPT(DFN,.1)),^(.1)]"",+($P($G(^PS(59.7,1,40.1)),"^")) D CKP^GMTSUP Q:$D(GMTSQIT)  W "Outpatient prescriptions are cancelled 72 hours after admission",!

 +5        DO CKP^GMTSUP

           if $DATA(GMTSQIT)

               QUIT

           WRITE !,"Drug....................................",?65,"Last",!

 +6        DO CKP^GMTSUP

           if $DATA(GMTSQIT)

               QUIT

 +7        WRITE ?18,"Rx #",?31,"Stat",?45,"Qty",?54,"Issued",?65,"Filled",?76,"Rem"

 +8        if $Y'>(IOSL-GMTSLO)!(+($GET(GUI))>0)

               WRITE !

 +9        QUIT

GMTSPSO.m