PSOTPCL ;BIRM/PDW-EDIT TPC INSTITUTION LETTERS
;;7.0;OUTPATIENT PHARMACY;**145,227**;DEC 1997
Q
EDIT ; Manual edit of institution letter information in 52.92
Q ;placed out of order by patch PSO*7*227
W @IOF
W !," Transitional Pharmacy Care"
W !," Edit Institution Letter Information"
EDIT2 W !!,"(You may add a NEW Institution at this point.)",!
D PSTINT
K DIC,DA
S DIC=52.92,DIC(0)="AEQML",DIC("W")="W ?40,$$GET1^DIQ(52.92,+Y,.02) W:$$CHKINST^PSOTPCL(+Y) ?69,"" Incomp""",DIC("A")="Select/Add TPB INSTITUTION: ",DLAYGO=52.92
D ^DIC K DLAYGO
G:Y'>0 EXIT
S DA=+Y,DR="[INSTITUTION EDIT]",DDSFILE=52.92
D ^DDS
G EDIT2
;
EXIT K DIC,DIE,DR,DDSFILE
W @IOF
Q
PSTINT ;Take institution entries from 52.91 & stuff into 52.92
S LOCDA=0 F S LOCDA=$O(^PS(52.91,"AC",LOCDA)) Q:LOCDA'>0 D LOCDA
Q
LOCDA ;Get physical and mailing address
I $D(^PS(52.92,LOCDA,0)) Q
N FAC,FDA
; set FAC(FLD#)=(INTvalue of FLD#); ex: FAC(.01)=500 :"Birmingham VAMC"
;
F XX=.01,.02,1.01,1.02,1.03,1.04 S FAC(XX)=$$GET1^DIQ(4,LOCDA,XX,"I")
F XX=4.01,4.02,4.03,4.04,4.05 S FAC(XX)=$$GET1^DIQ(4,LOCDA,XX,"I")
;
; build/map fields from iNSTITUTION file to TPB INSTITUTION LETTER
; file into FDA
; "XFDL^YFLD," stuff XFLD of file 52.92 with YFLD of file 4
;
F XX=".01^.01",".05^1.01",".06^1.02",".07^1.03",".08^1.04",".09^.02","1.01^4.01","1.02^4.02","1.03^4.03","1.04^4.04","1.05^4.05" D
. S XFLD=+XX,YFLD=$P(XX,U,2)
. S FDA(52.92,"+1,",XFLD)=FAC(YFLD)
S FDA(52.92,"+1,",.01)=LOCDA,LOCDA(1)=LOCDA
D UPDATE^DIE("","FDA","LOCDA","MSG")
Q
SEL ;Select divisions
; returns arrays
; for testing
W !!,"SELECTION OF INSTITUTION(S)",!
K DIVNM,DIVDA,DIVX
S DIVDA=0 F I=1:1 S DIVDA=$O(^PS(52.92,"B",DIVDA)) Q:DIVDA'>0 D
. Q:$$CHKINST(DIVDA) ; only completed institutions
. S DIV=$$GET1^DIQ(52.92,DIVDA,.01) S INST(DIVDA)=DIV
K DIR S DIR(0)="S^A:ALL INSTITUTIONS;S:SELECT INSTITUTIONS"
D ^DIR K DIR
G:Y="A" ALL
G:Y="S" SELECT
K INST
Q
SELECT ; select range of divisioins
K INST,DIC
S DIC="^PS(52.92,",DIC(0)="AEQM"
F S DIC("W")="W ?40,$E($$GET1^DIQ(52.92,+Y,.02),1,18) I $$CHKINST^PSOTPCL(+Y) W ?60,""Incomplete""" D ^DIC Q:Y'>0 D
. I $$CHKINST(+Y) W !,"Sorry, data for that institution is incomplete",! Q
. S INST(+Y)=$$GET1^DIQ(52.92,+Y,.01)
ALL K PSOSTOP
I '$D(INST) S INST="" W !,"None Selected - Quitting",! H 3 Q
W !!,"You have selected:",! S DIV=0 F II=1:1 D:'(II#18) PG Q:$G(PSOSTOP) S DIV=$O(INST(DIV)) Q:'DIV W !,?5,INST(DIV)
S DIR(0)="Y",DIR("A")="Is this correct ",DIR("B")="YES" D ^DIR
K DIR
Q:Y
G SEL
;
PG K DIR S DIR(0)="E",DIR("A")="CR - CONTINUE ^ - Quit" D ^DIR
S:X["^" PSOSTOP=1
Q
INSTCHK() ; check required fields of INST in the array INST(INSTDA)
N FAC S FAC=0
S INSTDA=0 F S INSTDA=$O(INST(INSTDA)) Q:INSTDA'>0 S XX=$$CHKINST(INSTDA) I $L(XX) W !,"Sorry, required field(s) are missing from ",INST(INSTDA) S FAC=1
I $G(FAC) D
. W !,"= = = = ="
. W !!,"The above institution(s) will need to have their letter information edited",!,"before the letters for that facility can be printed",!
. K DIR S DIR(0)="EO" D ^DIR K DIR
. I X["^" S PSOSTOP=1
Q FAC
;
CHKINST(INSTDA) ; check institution in 52.92 for required edited fields
N XX,FAC,PAR S FAC=""
; see if parent, parent checks OK
S PAR=$$GET1^DIQ(52.92,INSTDA,.02,"I") I PAR S XX=$$CHKINST(PAR) Q XX
F YY=.05,.07,.08,2.01 S XX=$$GET1^DIQ(52.92,INSTDA,YY) I $L(XX)=0 S FAC=FAC_YY_","
Q FAC
PTCHK() ; Check file 52.91 for INST fields and 52.92 for INSTUTITONs present
N INST,CHK,INSTDA S INSTDA=0,CHK=0
F S INSTDA=$O(^PS(52.91,"AC",INSTDA)) Q:INSTDA'>0 D
. I $D(^PS(52.92,INSTDA)) Q
. S CHK=1
. W !!,$$GET1^DIQ(4,INSTDA,.01),!," is missing from the TRANSITIONAL RX INSTITUTION LETTERS file #52.92",!,"and is being added."
. S LOCDA=INSTDA N INST,FAC D LOCDA ; add INSTDA to # 52.92
I CHK D
. W !,"= = = = ="
. W !!,"The above institution(s) will need to have their letter information edited",!,"before the letters for that facility can be printed",!
. K DIR S DIR(0)="EO",DIR("A")="<cr> - Continue" D ^DIR K DIR
Q CHK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPCL 4191 printed Nov 22, 2024@17:45:44 Page 2
PSOTPCL ;BIRM/PDW-EDIT TPC INSTITUTION LETTERS
+1 ;;7.0;OUTPATIENT PHARMACY;**145,227**;DEC 1997
+2 QUIT
EDIT ; Manual edit of institution letter information in 52.92
+1 ;placed out of order by patch PSO*7*227
QUIT
+2 WRITE @IOF
+3 WRITE !," Transitional Pharmacy Care"
+4 WRITE !," Edit Institution Letter Information"
EDIT2 WRITE !!,"(You may add a NEW Institution at this point.)",!
+1 DO PSTINT
+2 KILL DIC,DA
+3 SET DIC=52.92
SET DIC(0)="AEQML"
SET DIC("W")="W ?40,$$GET1^DIQ(52.92,+Y,.02) W:$$CHKINST^PSOTPCL(+Y) ?69,"" Incomp"""
SET DIC("A")="Select/Add TPB INSTITUTION: "
SET DLAYGO=52.92
+4 DO ^DIC
KILL DLAYGO
+5 if Y'>0
GOTO EXIT
+6 SET DA=+Y
SET DR="[INSTITUTION EDIT]"
SET DDSFILE=52.92
+7 DO ^DDS
+8 GOTO EDIT2
+9 ;
EXIT KILL DIC,DIE,DR,DDSFILE
+1 WRITE @IOF
+2 QUIT
PSTINT ;Take institution entries from 52.91 & stuff into 52.92
+1 SET LOCDA=0
FOR
SET LOCDA=$ORDER(^PS(52.91,"AC",LOCDA))
if LOCDA'>0
QUIT
DO LOCDA
+2 QUIT
LOCDA ;Get physical and mailing address
+1 IF $DATA(^PS(52.92,LOCDA,0))
QUIT
+2 NEW FAC,FDA
+3 ; set FAC(FLD#)=(INTvalue of FLD#); ex: FAC(.01)=500 :"Birmingham VAMC"
+4 ;
+5 FOR XX=.01,.02,1.01,1.02,1.03,1.04
SET FAC(XX)=$$GET1^DIQ(4,LOCDA,XX,"I")
+6 FOR XX=4.01,4.02,4.03,4.04,4.05
SET FAC(XX)=$$GET1^DIQ(4,LOCDA,XX,"I")
+7 ;
+8 ; build/map fields from iNSTITUTION file to TPB INSTITUTION LETTER
+9 ; file into FDA
+10 ; "XFDL^YFLD," stuff XFLD of file 52.92 with YFLD of file 4
+11 ;
+12 FOR XX=".01^.01",".05^1.01",".06^1.02",".07^1.03",".08^1.04",".09^.02","1.01^4.01","1.02^4.02","1.03^4.03","1.04^4.04","1.05^4.05"
Begin DoDot:1
+13 SET XFLD=+XX
SET YFLD=$PIECE(XX,U,2)
+14 SET FDA(52.92,"+1,",XFLD)=FAC(YFLD)
End DoDot:1
+15 SET FDA(52.92,"+1,",.01)=LOCDA
SET LOCDA(1)=LOCDA
+16 DO UPDATE^DIE("","FDA","LOCDA","MSG")
+17 QUIT
SEL ;Select divisions
+1 ; returns arrays
+2 ; for testing
+3 WRITE !!,"SELECTION OF INSTITUTION(S)",!
+4 KILL DIVNM,DIVDA,DIVX
+5 SET DIVDA=0
FOR I=1:1
SET DIVDA=$ORDER(^PS(52.92,"B",DIVDA))
if DIVDA'>0
QUIT
Begin DoDot:1
+6 ; only completed institutions
if $$CHKINST(DIVDA)
QUIT
+7 SET DIV=$$GET1^DIQ(52.92,DIVDA,.01)
SET INST(DIVDA)=DIV
End DoDot:1
+8 KILL DIR
SET DIR(0)="S^A:ALL INSTITUTIONS;S:SELECT INSTITUTIONS"
+9 DO ^DIR
KILL DIR
+10 if Y="A"
GOTO ALL
+11 if Y="S"
GOTO SELECT
+12 KILL INST
+13 QUIT
SELECT ; select range of divisioins
+1 KILL INST,DIC
+2 SET DIC="^PS(52.92,"
SET DIC(0)="AEQM"
+3 FOR
SET DIC("W")="W ?40,$E($$GET1^DIQ(52.92,+Y,.02),1,18) I $$CHKINST^PSOTPCL(+Y) W ?60,""Incomplete"""
DO ^DIC
if Y'>0
QUIT
Begin DoDot:1
+4 IF $$CHKINST(+Y)
WRITE !,"Sorry, data for that institution is incomplete",!
QUIT
+5 SET INST(+Y)=$$GET1^DIQ(52.92,+Y,.01)
End DoDot:1
ALL KILL PSOSTOP
+1 IF '$DATA(INST)
SET INST=""
WRITE !,"None Selected - Quitting",!
HANG 3
QUIT
+2 WRITE !!,"You have selected:",!
SET DIV=0
FOR II=1:1
if '(II#18)
DO PG
if $GET(PSOSTOP)
QUIT
SET DIV=$ORDER(INST(DIV))
if 'DIV
QUIT
WRITE !,?5,INST(DIV)
+3 SET DIR(0)="Y"
SET DIR("A")="Is this correct "
SET DIR("B")="YES"
DO ^DIR
+4 KILL DIR
+5 if Y
QUIT
+6 GOTO SEL
+7 ;
PG KILL DIR
SET DIR(0)="E"
SET DIR("A")="CR - CONTINUE ^ - Quit"
DO ^DIR
+1 if X["^"
SET PSOSTOP=1
+2 QUIT
INSTCHK() ; check required fields of INST in the array INST(INSTDA)
+1 NEW FAC
SET FAC=0
+2 SET INSTDA=0
FOR
SET INSTDA=$ORDER(INST(INSTDA))
if INSTDA'>0
QUIT
SET XX=$$CHKINST(INSTDA)
IF $LENGTH(XX)
WRITE !,"Sorry, required field(s) are missing from ",INST(INSTDA)
SET FAC=1
+3 IF $GET(FAC)
Begin DoDot:1
+4 WRITE !,"= = = = ="
+5 WRITE !!,"The above institution(s) will need to have their letter information edited",!,"before the letters for that facility can be printed",!
+6 KILL DIR
SET DIR(0)="EO"
DO ^DIR
KILL DIR
+7 IF X["^"
SET PSOSTOP=1
End DoDot:1
+8 QUIT FAC
+9 ;
CHKINST(INSTDA) ; check institution in 52.92 for required edited fields
+1 NEW XX,FAC,PAR
SET FAC=""
+2 ; see if parent, parent checks OK
+3 SET PAR=$$GET1^DIQ(52.92,INSTDA,.02,"I")
IF PAR
SET XX=$$CHKINST(PAR)
QUIT XX
+4 FOR YY=.05,.07,.08,2.01
SET XX=$$GET1^DIQ(52.92,INSTDA,YY)
IF $LENGTH(XX)=0
SET FAC=FAC_YY_","
+5 QUIT FAC
PTCHK() ; Check file 52.91 for INST fields and 52.92 for INSTUTITONs present
+1 NEW INST,CHK,INSTDA
SET INSTDA=0
SET CHK=0
+2 FOR
SET INSTDA=$ORDER(^PS(52.91,"AC",INSTDA))
if INSTDA'>0
QUIT
Begin DoDot:1
+3 IF $DATA(^PS(52.92,INSTDA))
QUIT
+4 SET CHK=1
+5 WRITE !!,$$GET1^DIQ(4,INSTDA,.01),!," is missing from the TRANSITIONAL RX INSTITUTION LETTERS file #52.92",!,"and is being added."
+6 ; add INSTDA to # 52.92
SET LOCDA=INSTDA
NEW INST,FAC
DO LOCDA
End DoDot:1
+7 IF CHK
Begin DoDot:1
+8 WRITE !,"= = = = ="
+9 WRITE !!,"The above institution(s) will need to have their letter information edited",!,"before the letters for that facility can be printed",!
+10 KILL DIR
SET DIR(0)="EO"
SET DIR("A")="<cr> - Continue"
DO ^DIR
KILL DIR
End DoDot:1
+11 QUIT CHK
