- 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 Jan 18, 2025@03:36:54 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