PSO145PS.m

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 ---PSO145PS   1062     printed  Apr 09, 2024@21:30:38                                                                                                                                                                                                    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