IBDFN3.m

IBDFN3 ;ALB/CJM - ENCOUNTER FORM - (entry points for reports);5/21/93

 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

RXPROF ;Outpatient Pharmacy Action Profile and Information Profile

 ;INPUTS:

 ;PSDAYS = number of days to print the medication profile for

 ;PSTYPE=1 for the Action Profile, =0 for the Information Profile

 ;DFN

 ;

 N IBDFN,ADDR,ADDRFL,CLASS,CNDT,DRUG,HDFL,I,II,J,L,LINE,P,PAGE,PSDOB,PSIIX,PSNAME,PSOI,PSSN,PSIX,PGM,PRF,PSDATE,VAL,VAR,RX,RX0,RX2,ST,ST0,PSDAY,RF,RFS

 N PSOPRINT,X1,X2,ZTSK,X,Y,PSII,PSDT,LMI,PSCNT,PSDIS,RXCNTLN,ELN,FN,CNT,VAERR,LN,PCLASS,PSOIFSUP,PSOINST,PSOSITE

 Q:(+$G(DFN)=0)

 S IBDFN=DFN

 S X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X

 S LINE=$TR($J(" ",IOM)," ","-")

 ;

 ; -- turn on barcoding for action profiles create parameter and check

 S PSOINST=$S($D(^DD("SITE",1)):$P(^(1),"^"),1:"000"),PSOPAR=1

 S PAGE=1 D HD^PSOSD2,PAT^PSOSD

 ;

 ; -- print OTHER MED INSTRUCTIONS and DUE's create parameter and check

 I PSTYPE,$L($T(RXPAD^PSOSD1)) D RXPAD^PSOSD1,ENSTUFF^PSODACT

 W:$Y @IOF

 ;

 S DFN=IBDFN

 K VA,VAEL,VAPA

 Q

 ;

DRUGS ;prints the medication profile of Outpatient Pharmacy

 ;doesn't seem to be needed, integration agreement not obtained to use this

 ;INPUTS:

 ;PLS=0 for long, 1 for short

 ;PSRT="D" to sort by date, "M" to sort by medication, "C" to sort by class

 ;DFN

 ;

 ;N IBDFN,DRUG,ZII,PHYS,CT,AL,I1,REF,LMI,PI,FN,Y,I,J,RX,DRX,ST,RX0,RX2,DA,D0,DIC,DIPGM,II,K,ST0,TEMP,Z,LMI,RXD,RXF,PI,AL,D0,DIPGM,II,PSCNT,PSDIV,PSLC,PSDIS

 ;

 ;S (FN,IBDFN,D0,DA)=DFN

 ;I '$D(^PS(55,IBDFN,"P")),'$D(^("ARC")) D ^PSODEM W !?20,"NO PHARMACY INFORMATION" G RXQ

 ;I '$O(^PS(55,IBDFN,"P",0)),$D(^PS(55,IBDFN,"ARC")) D ^PSODEM W !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",! G RXQ

 ;D P^PSOP

RXQ ;W @IOF

 ;S DFN=IBDFN

 ;K ^UTILITY($J)

 Q

ROUTING ;entry point for printing a routing sheet for a single patient

 ;Sets IBPRINT=1 so that it will be known that this entry point was used

 ;inputs - 

 ;    DFN

 ;    IBAPPT - the appointment

 ;    IBCLINIC - pointer to the clinic

 ;protect variables that may be changed

 N %,%DT,%I,ADDR,ALL,APDATE,IBDFN,DGMT,DIC,DIV,G,GDATE,H,I,J,K,L,LL,M,NAME,NDATE,ORD,ORDER,P,POP,PRDATE

 N SC,SDA,SDATE,SDCNT,SDI,SDI1,SDIQ,SDM,SDREP,SDSP,SDSTART,SDVA,SDX,SDX1,SSN,SZ,TDO,X,X1,Y,ZIP,ZX,VAR,C,V,SDEF,A,SD,SCN,SDTD,SDSCCOND,SDPARMS

 ;

 ;protect DFN

 Q:(+$G(DFN)=0)

 S IBDFN=DFN N DFN S DFN=IBDFN

 ;

 ;set the start date to the date of the appt

 S SDPARMS("START")=IBAPPT\1

 ;keep the device open

 S SDPARMS("DO NOT CLOSE")=1

 ;set DIV to the division of IBCLINIC

 S DIV=$P($G(^SC(IBCLINIC,0)),"^",15)

 D EN1^SDROUT1

 Q

IBDFN3    ;ALB/CJM - ENCOUNTER FORM - (entry points for reports);5/21/93

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

RXPROF    ;Outpatient Pharmacy Action Profile and Information Profile

 +1       ;INPUTS:

 +2       ;PSDAYS = number of days to print the medication profile for

 +3       ;PSTYPE=1 for the Action Profile, =0 for the Information Profile

 +4       ;DFN

 +5       ;

 +6        NEW IBDFN,ADDR,ADDRFL,CLASS,CNDT,DRUG,HDFL,I,II,J,L,LINE,P,PAGE,PSDOB,PSIIX,PSNAME,PSOI,PSSN,PSIX,PGM,PRF,PSDATE,VAL,VAR,RX,RX0,RX2,ST,ST0,PSDAY,RF,RFS

 +7        NEW PSOPRINT,X1,X2,ZTSK,X,Y,PSII,PSDT,LMI,PSCNT,PSDIS,RXCNTLN,ELN,FN,CNT,VAERR,LN,PCLASS,PSOIFSUP,PSOINST,PSOSITE

 +8        IF (+$GET(DFN)=0)

               QUIT 

 +9        SET IBDFN=DFN

 +10       SET X1=DT

           SET X2=-PSDAYS

           DO C^%DTC

           SET (PSDATE,PSDAY)=X

 +11       SET LINE=$TRANSLATE($JUSTIFY(" ",IOM)," ","-")

 +12      ;

 +13      ; -- turn on barcoding for action profiles create parameter and check

 +14       SET PSOINST=$SELECT($DATA(^DD("SITE",1)):$PIECE(^(1),"^"),1:"000")

           SET PSOPAR=1

 +15       SET PAGE=1

           DO HD^PSOSD2

           DO PAT^PSOSD

 +16      ;

 +17      ; -- print OTHER MED INSTRUCTIONS and DUE's create parameter and check

 +18       IF PSTYPE

               IF $LENGTH($TEXT(RXPAD^PSOSD1))

                   DO RXPAD^PSOSD1

                   DO ENSTUFF^PSODACT

 +19       IF $Y

               WRITE @IOF

 +20      ;

 +21       SET DFN=IBDFN

 +22       KILL VA,VAEL,VAPA

 +23       QUIT 

 +24      ;

DRUGS     ;prints the medication profile of Outpatient Pharmacy

 +1       ;doesn't seem to be needed, integration agreement not obtained to use this

 +2       ;INPUTS:

 +3       ;PLS=0 for long, 1 for short

 +4       ;PSRT="D" to sort by date, "M" to sort by medication, "C" to sort by class

 +5       ;DFN

 +6       ;

 +7       ;N IBDFN,DRUG,ZII,PHYS,CT,AL,I1,REF,LMI,PI,FN,Y,I,J,RX,DRX,ST,RX0,RX2,DA,D0,DIC,DIPGM,II,K,ST0,TEMP,Z,LMI,RXD,RXF,PI,AL,D0,DIPGM,II,PSCNT,PSDIV,PSLC,PSDIS

 +8       ;

 +9       ;S (FN,IBDFN,D0,DA)=DFN

 +10      ;I '$D(^PS(55,IBDFN,"P")),'$D(^("ARC")) D ^PSODEM W !?20,"NO PHARMACY INFORMATION" G RXQ

 +11      ;I '$O(^PS(55,IBDFN,"P",0)),$D(^PS(55,IBDFN,"ARC")) D ^PSODEM W !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",! G RXQ

 +12      ;D P^PSOP

RXQ       ;W @IOF

 +1       ;S DFN=IBDFN

 +2       ;K ^UTILITY($J)

 +3        QUIT 

ROUTING   ;entry point for printing a routing sheet for a single patient

 +1       ;Sets IBPRINT=1 so that it will be known that this entry point was used

 +2       ;inputs - 

 +3       ;    DFN

 +4       ;    IBAPPT - the appointment

 +5       ;    IBCLINIC - pointer to the clinic

 +6       ;protect variables that may be changed

 +7        NEW %,%DT,%I,ADDR,ALL,APDATE,IBDFN,DGMT,DIC,DIV,G,GDATE,H,I,J,K,L,LL,M,NAME,NDATE,ORD,ORDER,P,POP,PRDATE

 +8        NEW SC,SDA,SDATE,SDCNT,SDI,SDI1,SDIQ,SDM,SDREP,SDSP,SDSTART,SDVA,SDX,SDX1,SSN,SZ,TDO,X,X1,Y,ZIP,ZX,VAR,C,V,SDEF,A,SD,SCN,SDTD,SDSCCOND,SDPARMS

 +9       ;

 +10      ;protect DFN

 +11       IF (+$GET(DFN)=0)

               QUIT 

 +12       SET IBDFN=DFN

           NEW DFN

           SET DFN=IBDFN

 +13      ;

 +14      ;set the start date to the date of the appt

 +15       SET SDPARMS("START")=IBAPPT\1

 +16      ;keep the device open

 +17       SET SDPARMS("DO NOT CLOSE")=1

 +18      ;set DIV to the division of IBCLINIC

 +19       SET DIV=$PIECE($GET(^SC(IBCLINIC,0)),"^",15)

 +20       DO EN1^SDROUT1

 +21       QUIT