APSQCK2 ;IHS ASDS/ENM/POC - CONTINUE FROM APSQCK
;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
;
;POST INIT FROM POST^APSQBEG
;DOUBT IF THIS ROUTINE IS NEEDED SINCE DOING A KIDS INSTALL
POST ;EP POST INIT TO DO
S MENU="APSQ NF MENU"
S X=$$ADD^XPDMENU("PSO MANAGER",MENU,"NON")
I X W !,MENU_" ADDED TO MENU"
E W !,MENU_" MENU NOT ADDED"
D FREST
Q
FSAVE ;MY USE TO MAKE FILEGRAMS
D ^XBKSET
S DIC(0)="XMQ"
S DIC="^DIPT("
S X="MAIL GROUP"
D ^DIC
I Y<1 W !,"YOU HAVE NO PRINT TEMPLATE NAMED "_X_". MAKE IT!" G KKILL
K DIC
S SAVDIFGT=+Y
;S COM="APSQ NF "
;F I=COM_"APPROVING PROVIDER",COM_"PHARMACIST",COM_"PT REVIEW",COM_"REQUESTING PROVIDER" D
;F I=1:1 S TEXT=$P($T(STUFF+I),";;",2) Q:TEXT="END" D
F II=1:1 S TEXT=$P($T(STUFF+II),";;",2) Q:TEXT="END" D
.S X=$P(TEXT,",",1)
.S DIC(0)="MQX",DIC="^XMB(3.8,"
.D ^DIC
.I Y>0 D
..S DIFGT=SAVDIFGT
..S DIFG("FE")=+Y
..S DIFG("FUNC")="A"
..S DIFG("FGR")="^APSQ("""_$P(TEXT,",",1)_""","
..D EN^DIFGG
..K DIFG
Q
KKILL ;KILL STUFF
K DIC,X,II
Q
FREST ;RESTORE FILEGRAMS
I '$D(^APSQ) W !,"WHERE IS THE GLOBAL ^APSQ???" G KKILL
D ^XBKSET
;S COM="^APSQ(""APSQ NF "
;F I=COM_"APPROVING PROVIDER"",",COM_"PHARMACIST"",",COM_"PT REVIEW"",",COM_"REQUESTING PROVIDER""," D
F II=1:1 S TEXT=$P($T(STUFF+II),";;",2) Q:TEXT="END" D
.S DIFGLO="^APSQ("""_$P(TEXT,",",1)_""","
.S DIADD=1
.D ^DIFG
.W !,"MAIL GROUP "_$P(TEXT,",",1)_" WAS "_$S($D(DIFGER):"NOT",1:"")_"ADDED."
.K DIFGER
.Q
;ADD THE RIGHT MAIL GROUPS TO BULLETINS
F II=1:1 S TEXT=$P($T(STUFF+II),";;",2) Q:TEXT="END" D
.S DIC="^XMB(3.6,",DIC(0)="XMQ",X=$P(TEXT,",",2)
.D ^DIC
.S IEN=+Y
.S DIC(0)="LMQX"
.S DA(1)=IEN
.S DIC("P")=$P(^DD(3.6,4,0),"^",2)
.S DIC=DIC_IEN_",2,",X=$P(TEXT,",",1)
.D ^DIC
.K DIC,DA
.Q
D KKILL
Q
STUFF ;MAIL GROUP,BULLETIN
;;APSQ NF APPROVING PROVIDER,APSQ NF APPROVING BULLETIN
;;APSQ NF PHARMACIST,APSQ NF PHARMACIST BULLETIN
;;APSQ NF PT REVIEW,APSQ NF PT BULLETIN
;;APSQ NF REQUESTING PROVIDER,APSQ NF REQUESTING BULLETIN
;;END
APSQCK2 ;IHS ASDS/ENM/POC - CONTINUE FROM APSQCK
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
+2 ;
+3 ;POST INIT FROM POST^APSQBEG
+4 ;DOUBT IF THIS ROUTINE IS NEEDED SINCE DOING A KIDS INSTALL
POST ;EP POST INIT TO DO
+1 SET MENU="APSQ NF MENU"
+2 SET X=$$ADD^XPDMENU("PSO MANAGER",MENU,"NON")
+3 IF X
WRITE !,MENU_" ADDED TO MENU"
+4 IF '$TEST
WRITE !,MENU_" MENU NOT ADDED"
+5 DO FREST
+6 QUIT
FSAVE ;MY USE TO MAKE FILEGRAMS
+1 DO ^XBKSET
+2 SET DIC(0)="XMQ"
+3 SET DIC="^DIPT("
+4 SET X="MAIL GROUP"
+5 DO ^DIC
+6 IF Y<1
WRITE !,"YOU HAVE NO PRINT TEMPLATE NAMED "_X_". MAKE IT!"
GOTO KKILL
+7 KILL DIC
+8 SET SAVDIFGT=+Y
+9 ;S COM="APSQ NF "
+10 ;F I=COM_"APPROVING PROVIDER",COM_"PHARMACIST",COM_"PT REVIEW",COM_"REQUESTING PROVIDER" D
+11 ;F I=1:1 S TEXT=$P($T(STUFF+I),";;",2) Q:TEXT="END" D
+12 FOR II=1:1
SET TEXT=$PIECE($TEXT(STUFF+II),";;",2)
IF TEXT="END"
QUIT
Begin DoDot:1
+13 SET X=$PIECE(TEXT,",",1)
+14 SET DIC(0)="MQX"
SET DIC="^XMB(3.8,"
+15 DO ^DIC
+16 IF Y>0
Begin DoDot:2
+17 SET DIFGT=SAVDIFGT
+18 SET DIFG("FE")=+Y
+19 SET DIFG("FUNC")="A"
+20 SET DIFG("FGR")="^APSQ("""_$PIECE(TEXT,",",1)_""","
+21 DO EN^DIFGG
+22 KILL DIFG
End DoDot:2
End DoDot:1
+23 QUIT
KKILL ;KILL STUFF
+1 KILL DIC,X,II
+2 QUIT
FREST ;RESTORE FILEGRAMS
+1 IF '$DATA(^APSQ)
WRITE !,"WHERE IS THE GLOBAL ^APSQ???"
GOTO KKILL
+2 DO ^XBKSET
+3 ;S COM="^APSQ(""APSQ NF "
+4 ;F I=COM_"APPROVING PROVIDER"",",COM_"PHARMACIST"",",COM_"PT REVIEW"",",COM_"REQUESTING PROVIDER""," D
+5 FOR II=1:1
SET TEXT=$PIECE($TEXT(STUFF+II),";;",2)
IF TEXT="END"
QUIT
Begin DoDot:1
+6 SET DIFGLO="^APSQ("""_$PIECE(TEXT,",",1)_""","
+7 SET DIADD=1
+8 DO ^DIFG
+9 WRITE !,"MAIL GROUP "_$PIECE(TEXT,",",1)_" WAS "_$SELECT($DATA(DIFGER):"NOT",1:"")_"ADDED."
+10 KILL DIFGER
+11 QUIT
End DoDot:1
+12 ;ADD THE RIGHT MAIL GROUPS TO BULLETINS
+13 FOR II=1:1
SET TEXT=$PIECE($TEXT(STUFF+II),";;",2)
IF TEXT="END"
QUIT
Begin DoDot:1
+14 SET DIC="^XMB(3.6,"
SET DIC(0)="XMQ"
SET X=$PIECE(TEXT,",",2)
+15 DO ^DIC
+16 SET IEN=+Y
+17 SET DIC(0)="LMQX"
+18 SET DA(1)=IEN
+19 SET DIC("P")=$PIECE(^DD(3.6,4,0),"^",2)
+20 SET DIC=DIC_IEN_",2,"
SET X=$PIECE(TEXT,",",1)
+21 DO ^DIC
+22 KILL DIC,DA
+23 QUIT
End DoDot:1
+24 DO KKILL
+25 QUIT
STUFF ;MAIL GROUP,BULLETIN
+1 ;;APSQ NF APPROVING PROVIDER,APSQ NF APPROVING BULLETIN
+2 ;;APSQ NF PHARMACIST,APSQ NF PHARMACIST BULLETIN
+3 ;;APSQ NF PT REVIEW,APSQ NF PT BULLETIN
+4 ;;APSQ NF REQUESTING PROVIDER,APSQ NF REQUESTING BULLETIN
+5 ;;END
