PSNEWCLS ;BIR/DMA-NOTIFY OF CLASS CHANGES ; 17 Jun 2009 7:08 AM
;;4.0; NATIONAL DRUG FILE;**176,100**; 30 Oct 98;Build 5
;
;Reference to UPDATE^GMRAUTL2 supported by DBIA #4667
;
K ^TMP("PSN1",$J),^TMP("PSNN",$J) N CLASS,DA,DIE,DR,LIN,NC,OC,PR,PSDA,PSNG,PSNGD,PSNK,X,XMDUZ,XMSUB,XMTEXT,XMY
S DA=0 F S DA=$O(^TMP("PSN",$J,DA)) Q:'DA S PSDA=^(DA,0) D
.K CLASS S CLASS("D",$P(PSDA,"^",2))="",CLASS("A",$P(PSDA,"^",3))="",X=$P(PSDA,"^",4)_";PSNDF(50.6,^"_$P(^PSNDF(50.6,$P(PSDA,"^",4),0),"^")
.S PSNG=$P(^PSNDF(50.68,DA,0),"^",2),PSNK=0,PSNGD=0 F S PSNGD=$O(^PSNDF(50.6,"APRO",PSNG,PSNGD)) Q:'PSNGD I $P(^PSNDF(50.68,PSNGD,3),"^")=$P(PSDA,"^",2) S PSNK=1 Q
.I PSNK K CLASS("D")
.I $T(UPDATE^GMRAUTL2)]"" D UPDATE^GMRAUTL2(X,,.CLASS)
.S PR=$P(^PSNDF(50.68,+PSDA,0),"^"),OC=$P(^PS(50.605,$P(PSDA,"^",2),0),"^"),NC=$P(^PS(50.605,$P(PSDA,"^",3),0),"^"),^TMP("PSN1",$J,PR_"^"_OC_"^"_NC)=""
;
S LIN=1,DA="" F S DA=$O(^TMP("PSN1",$J,DA)) Q:DA="" S ^TMP("PSNN",$J,LIN,0)="Product: "_$P(DA,"^"),^TMP("PSNN",$J,LIN+1,0)="Old Class: "_$P(DA,"^",2),^TMP("PSNN",$J,LIN+2,0)="New Class: "_$P(DA,"^",3),^TMP("PSNN",$J,LIN+3,0)=" ",LIN=LIN+4
;
K XMY S XMY(DUZ)="",XMY("G.NDF DATA@"_^XMB("NETNAME"))="" S DA=0 F S DA=$O(^XUSEC("PSNMGR",DA)) Q:'DA S XMY(DA)=""
S XMDUZ="NDF MANAGER",XMSUB="Products with changed classes",XMTEXT="^TMP(""PSNN"",$J," D ^XMD
;
K CLASS,DA,DIE,DR,LIN,NC,OC,PR,PSDA,PSNG,PSNGD,PSNK,X,XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSN1",$J),^TMP("PSNN",$J) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNEWCLS 1492 printed Dec 13, 2024@02:23:58 Page 2
PSNEWCLS ;BIR/DMA-NOTIFY OF CLASS CHANGES ; 17 Jun 2009 7:08 AM
+1 ;;4.0; NATIONAL DRUG FILE;**176,100**; 30 Oct 98;Build 5
+2 ;
+3 ;Reference to UPDATE^GMRAUTL2 supported by DBIA #4667
+4 ;
+5 KILL ^TMP("PSN1",$JOB),^TMP("PSNN",$JOB)
NEW CLASS,DA,DIE,DR,LIN,NC,OC,PR,PSDA,PSNG,PSNGD,PSNK,X,XMDUZ,XMSUB,XMTEXT,XMY
+6 SET DA=0
FOR
SET DA=$ORDER(^TMP("PSN",$JOB,DA))
if 'DA
QUIT
SET PSDA=^(DA,0)
Begin DoDot:1
+7 KILL CLASS
SET CLASS("D",$PIECE(PSDA,"^",2))=""
SET CLASS("A",$PIECE(PSDA,"^",3))=""
SET X=$PIECE(PSDA,"^",4)_";PSNDF(50.6,^"_$PIECE(^PSNDF(50.6,$PIECE(PSDA,"^",4),0),"^")
+8 SET PSNG=$PIECE(^PSNDF(50.68,DA,0),"^",2)
SET PSNK=0
SET PSNGD=0
FOR
SET PSNGD=$ORDER(^PSNDF(50.6,"APRO",PSNG,PSNGD))
if 'PSNGD
QUIT
IF $PIECE(^PSNDF(50.68,PSNGD,3),"^")=$PIECE(PSDA,"^",2)
SET PSNK=1
QUIT
+9 IF PSNK
KILL CLASS("D")
+10 IF $TEXT(UPDATE^GMRAUTL2)]""
DO UPDATE^GMRAUTL2(X,,.CLASS)
+11 SET PR=$PIECE(^PSNDF(50.68,+PSDA,0),"^")
SET OC=$PIECE(^PS(50.605,$PIECE(PSDA,"^",2),0),"^")
SET NC=$PIECE(^PS(50.605,$PIECE(PSDA,"^",3),0),"^")
SET ^TMP("PSN1",$JOB,PR_"^"_OC_"^"_NC)=""
End DoDot:1
+12 ;
+13 SET LIN=1
SET DA=""
FOR
SET DA=$ORDER(^TMP("PSN1",$JOB,DA))
if DA=""
QUIT
SET ^TMP("PSNN",$JOB,LIN,0)="Product: "_$PIECE(DA,"^")
SET ^TMP("PSNN",$JOB,LIN+1,0)="Old Class: "_$PIECE(DA,"^",2)
SET ^TMP("PSNN",$JOB,LIN+2,0)="New Class: "_$PIECE(DA,"^",3)
SET ^TMP("PSNN",$JOB,LIN+3,0)=" "
SET LIN=LIN+4
+14 ;
+15 KILL XMY
SET XMY(DUZ)=""
SET XMY("G.NDF DATA@"_^XMB("NETNAME"))=""
SET DA=0
FOR
SET DA=$ORDER(^XUSEC("PSNMGR",DA))
if 'DA
QUIT
SET XMY(DA)=""
+16 SET XMDUZ="NDF MANAGER"
SET XMSUB="Products with changed classes"
SET XMTEXT="^TMP(""PSNN"",$J,"
DO ^XMD
+17 ;
+18 KILL CLASS,DA,DIE,DR,LIN,NC,OC,PR,PSDA,PSNG,PSNGD,PSNK,X,XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSN1",$JOB),^TMP("PSNN",$JOB)
QUIT
