PSO145PS ;BIRM/PDW-POST INIT TO POPULATE TPB INSTITUTION LETTERS 52.92 ;AUG 5, 2003
;;7.0;OUTPATIENT PHARMACY;**145**;DEC 1997
Q
EN ;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 ;Do not duplicate a site
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 for FM update
;
; "XFDL^YFLD" stuff file #52.92(XFLD) FDA with file #4(YFLD)
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO145PS 1062 printed Sep 23, 2025@19:58:44 Page 2
PSO145PS ;BIRM/PDW-POST INIT TO POPULATE TPB INSTITUTION LETTERS 52.92 ;AUG 5, 2003
+1 ;;7.0;OUTPATIENT PHARMACY;**145**;DEC 1997
+2 QUIT
EN ;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 ;Do not duplicate a site
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 for FM update
+10 ;
+11 ; "XFDL^YFLD" stuff file #52.92(XFLD) FDA with file #4(YFLD)
+12 ;
+13 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
+14 SET XFLD=+XX
SET YFLD=$PIECE(XX,U,2)
+15 SET FDA(52.92,"+1,",XFLD)=FAC(YFLD)
End DoDot:1
+16 SET FDA(52.92,"+1,",.01)=LOCDA
SET LOCDA(1)=LOCDA
+17 DO UPDATE^DIE("","FDA","LOCDA","MSG")
+18 QUIT
